Specify folder and date range to get data from Outlook

[ricciolo]

Hi,

I have code for a macro so that I could get data from Outlook.

Option Explicit

Dim arrData() As Variant
Dim Cnt As Long


Sub test()


    Dim olApp As Object
    Dim olNS As Object
    Dim olFldr As Object
    
    Set olApp = CreateObject("Outlook.Application")
    
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.GetDefaultFolder(5) '5=olSentMail
    
    Cnt = 0
    
    Call RecursiveFolders(olFldr)
    
    Cells.ClearContents
    
    With ActiveSheet.Range("a1").Resize(, 5)
        .Value = Array("Folder", "To", "Subject", "Importance", "Sent")
        .Font.Bold = True
    End With
    
    ActiveSheet.Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
    
    ActiveSheet.Range("E2", Range("E2").End(xlDown)).NumberFormat = "mm/dd/yyyy h:mm AM/PM"
    
    ActiveSheet.Columns.AutoFit
    
End Sub


Sub RecursiveFolders(olFolder As Object)


    Dim olSubFolder As Object
    Dim olMail As Object


    For Each olMail In olFolder.Items
        Cnt = Cnt + 1
        ReDim Preserve arrData(1 To 5, 1 To Cnt)
        arrData(1, Cnt) = olFolder.FolderPath
        arrData(2, Cnt) = olMail.To
        arrData(3, Cnt) = olMail.Subject
        arrData(4, Cnt) = olMail.Importance
        arrData(5, Cnt) = olMail.SentOn
    Next
    
    For Each olSubFolder In olFolder.Folders
        Call RecursiveFolders(olSubFolder)
    Next olSubFolder
    
End Sub

I can hardcode where I get the data from with:

Set olFldr = olNS.GetDefaultFolder(5) '5=olFolderSentMail, 6=olFolderInbox

However, I was wondering if it was possible to make some kind of button or form so that I can select a folder (Inbox, Sent Items, Archive, etc.) and to select a date range (e.g., if I wanted to see the info for the emails I sent during the last two weeks instead of ALL the emails in the Sent Items folder).

Would it be easier to do this as a macro from Outlook (export data to Excel) vs. a macro in Excel (import data from Outlook)?

Thanks!

 

[tweedle]

The Resize to null or zero can't work because a Range has to have at least 1 col/1 row minimum.

I think you can escape like this.

Sub getOutlookInfo(fromDt As Date, toDt As Date)


< Snip >


Call RecursiveFolders(olFldr)


[COLOR=#0000ff]If UBound(arrData()) = 0 then Exit Sub[/COLOR]


< Snip >


End Sub

 

[tweedle]

My last post was off a tad.
Since you're dealing with a potentially un-initialized array, you have to trap the error.

' < snip >


Call RecursiveFolders(olFldr)
On Error GoTo Escape:
retval = UBound(arrData)


' < snip >


Exit Sub
Escape:
With Err
    Debug.Print .Number, .Description
    .Clear
End With
End Sub

 

[ricciolo]

I edited the code so that I could trap the error. However, I occasionally run into a Error 13 Type Mismatch error, and I have no idea why it's happening. Do you have any thoughts?

Option Explicit

Dim arrData() As Variant
Dim Cnt As Long
Dim txtSender As String
Dim txtTime As String
Dim sinceDt As Date
Dim untilDt As Date
Dim retval As Integer


Sub getOutlookInfo(fromDt As Date, toDt As Date)
    On Error GoTo Escape
    
    Dim olApp As Object
    Dim olNS As Object
    Dim olFldr As Object
    
    Set olApp = CreateObject("Outlook.Application")
    
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.PickFolder
    'Set olFldr = olNS.GetDefaultFolder(6)
    
    sinceDt = fromDt
    untilDt = toDt
    
    Cnt = 0
    
    If olFldr Is Nothing Then
        Exit Sub
    End If
    
    Sheet2.Cells.ClearContents
    
    Call RecursiveFolders(olFldr)
    
    Select Case olFldr
        Case "Inbox"
            txtSender = "From"
            txtTime = "Received"
        Case "Sent Items"
            txtSender = "To"
            txtTime = "Sent On"
        Case Else
            txtSender = "To/From"
            txtTime = "Received"
    End Select
    
    Sheet2.Select
    
    With Sheet2.Range("a1").Resize(, 5)
        .Value = Array("Folder", txtSender, "Subject", txtTime, "Importance")
        .Font.Bold = True
    End With
    
    retval = UBound(arrData)
    
    Sheet2.Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
    Sheet2.Range("D2", Range("D2").End(xlDown)).NumberFormat = "mm/dd/yyyy h:mm AM/PM"
    Sheet2.Columns.AutoFit
    
Escape:
    Select Case Err.Number
        Case 9
            'Unitialized array
            Debug.Print Err.Number & ": " & Err.Description
            ReDim Preserve arrData(1 To 5, 1 To 1)
            arrData(1, 1) = "No emails within range."
            Resume Next
    End Select


    Erase arrData
End Sub


Sub RecursiveFolders(olFolder As Object)
    On Error GoTo ErrHandler


    Dim olSubFolder As Object
    Dim olMail As Object
    Dim compareDt As Date
    Dim olItems As Object
    
    'Check to see which folders exist
    'MsgBox olFolder.Name
    
    Set olItems = olFolder.Items
    'Reorder the mail items in descending order
    Select Case olFolder
        Case "Sent Items"
            olItems.Sort ["SentOn"], True
        Case Else
            olItems.Sort ["ReceivedTime"], True
    End Select
    
    'olItems.Sort ["ReceivedTime"], True
    
    For Each olMail In olItems
    
        If TypeOf olMail Is MailItem Then
            compareDt = DateSerial(Year(olMail.ReceivedTime), Month(olMail.ReceivedTime), Day(olMail.ReceivedTime))
        
            'Check if the MailItem is within the date range
            If (compareDt >= sinceDt) And (compareDt <= untilDt) Then
                Cnt = Cnt + 1
                
                ReDim Preserve arrData(1 To 5, 1 To Cnt)
                
                arrData(1, Cnt) = olFolder.FolderPath
                arrData(3, Cnt) = olMail.Subject
                arrData(5, Cnt) = olMail.Importance
            
                Select Case olFolder
                Case "Sent Items"
                    arrData(2, Cnt) = olMail.To
                    arrData(4, Cnt) = olMail.SentOn
                Case Else
                    arrData(2, Cnt) = olMail.SenderName
                    arrData(4, Cnt) = olMail.ReceivedTime
                End Select
            'If the MailItem is before the date range, exit sub
            ElseIf (compareDt < sinceDt) Then
                Exit Sub
            End If
        End If
    Next
    
    For Each olSubFolder In olFolder.Folders
        Call RecursiveFolders(olSubFolder)
    Next olSubFolder
    
ErrHandler:
    Select Case Err.Number
        Case 440
            'Property doesn't exist
            Exit Sub
    End Select
    
End Sub

The code goes through RecursiveFolders() successfully, but when I get to this line:

Sheet2.Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)

I get the Error 13. At first I thought it may occur if I have a blank subject line, but that doesn't seem to be the case? For olMail.Subject with an empty subject line, arrData(3, Cnt) gets an empty string (""). Otherwise, the elements of the array seem to be filled in correctly. I'm really stumped by this error.

Thanks for your time!

 

[tweedle]

I've run the code multitudes and have not replicated the error.

 

[ricciolo]

Hmm. I know you said that you haven't been able to replicate the problem, but do you have any ideas for what might be causing it? Would a 2007 vs. 2010 version of Excel be an issue? I've tried to step through the code, and it gets stuck on the quoted line above, but I'm not sure what's wrong with the array data (if there's anything wrong with it) or how a mismatch error would occur.

Thanks so much!!

 

[ricciolo]

I've been tinkering with Outlook and the code, and I think the issue is with Transpose and the size of the array. If I try to paste the array w/o transposing it (so that the array is "wide" with many columns instead of "tall" with many rows), the code works fine.

That surprises me because I thought the limit for arrays was something along the lines of 64K-65K elements (2^16) and arrData has fewer elements than that.

Do you have any suggestions for what I can use besides Transpose? Or should I try to manually transpose the data (e.g., set up a second array and switch the indices)?

I noticed that if I manually transpose the data using "Paste Special", the data in the Worksheet transposes correctly.

Thanks again for your time!

 

[trioxygin]

I have the same problem too. its not about the limitation. i tried to limit only 5 emails to capture but i still get a type mismatch on that line... i wonder what the problem is??