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]

but I can't run JUST the code without inputs?

That's correct when passing values into a procedure, you need to then call the procedure from another procedure.
You can also call it from your Immediate window (Ctrl + g).
ex. getOutlookInfo cdate("01/01/2013"), cdate("03/01/2013")


These aren't objects, it's a variable reassignment, so 'Set' isn't needed.
sinceDt = fromDt
untilDt = toDt

Sorry for so many posts...

No worries

 

[ricciolo]

Got it.

Do you mind if I ask a question about the userform? This is my code for it:

Dim fromDate As DateDim toDate As Date

Private Sub cboFromDate_Change()
Select Case cboFromDate.ListIndex
    Case Is = 0
        txtFromDate.Value = Date - 30
        Me.txtFromDate.Enabled = False
    Case Is = 1
        txtFromDate.Value = Date - 14
        Me.txtFromDate.Enabled = False
    Case Is = 2
        txtFromDate.Value = Date - 7
        Me.txtFromDate.Enabled = False
    Case Is = 3
        Me.txtFromDate.Enabled = True
        txtFromDate.SetFocus
    End Select

    fromDate = txtFromDate.Value
End Sub

Private Sub cboToDate_Change()
Select Case cboToDate.ListIndex
    Case Is = 0
        txtToDate.Value = Date
        Me.txtToDate.Enabled = False
    Case Is = 1
        Me.txtToDate.Enabled = True
        txtFromDate.SetFocus
    End Select
    
    toDate = txtToDate.Value
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()

With cboFromDate
    .AddItem "30 days before"
    .AddItem "14 days before"
    .AddItem "7 days before"
    .AddItem "Enter date"
End With

With cboToDate
    .AddItem "Today"
    .AddItem "Enter date"
End With

End Sub

Private Sub cmdRun_Click()
    If cboToDate.ListIndex = 1 Then
        If Not IsDate(Me.txtToDate.Value) Then
            MsgBox "Invalid input. Please enter a date.", vbExclamation, "Outlook Report"
            Me.txtToDate.SetFocus
            Exit Sub
        End If
    End If
    
    Call getOutlookInfo(fromDate, toDate)
    
    Unload Me
End Sub

The text boxes (txtFromDate, txtToDate) should be disabled if the user selects anything other than "Select date" in the combo boxes. When "Select date" is chosen, then he/she should be able to enter the date into the textbook and the value should be read and put into the variable "fromDate" (and "toDate" for the other textbook). Otherwise, the calculated dates (30 days before, etc.) are what go into the variables.

The code works correctly for the values other than "Select date", but when I choose "Select date", the code just reads the blank instead of letting the user enter the date. Do you have any suggestions for how to correct this?

 

[tweedle]

Sure;
See code comments.
Good Job!

Dim fromDate As Date
Dim toDate As Date


'=========================================================
Private Sub UserForm_Initialize()


    With cboFromDate
        .AddItem "30 days before"
        .AddItem "14 days before"
        .AddItem "7 days before"
        .AddItem "Enter date"
    End With


    With cboToDate
        .AddItem "Today"
        .AddItem "Enter date"
    End With


End Sub


Private Sub cmdCancel_Click()
    Unload Me
End Sub
'=========================================================


Private Sub cboFromDate_Change()


    Select Case cboFromDate.ListIndex
        Case Is = 0
            txtFromDate.Value = Date - 30
            Me.txtFromDate.Enabled = False
        Case Is = 1
            txtFromDate.Value = Date - 14
            Me.txtFromDate.Enabled = False
        Case Is = 2
            txtFromDate.Value = Date - 7
            Me.txtFromDate.Enabled = False
        Case Is = 3
            Me.txtFromDate.Enabled = True
            txtFromDate.SetFocus
    End Select


    'When you set the variable here, the user hasn't had opportunity to enter into the textbox; move it to cmdRun
    'Also textbox will have a string, and variable is declared as Date; should use cdate(txtToDate.Value)
    'fromDate = txtFromDate.Value
End Sub




Private Sub cboToDate_Change()
    Select Case cboToDate.ListIndex
        Case Is = 0
            txtToDate.Value = Date
            Me.txtToDate.Enabled = False
        Case Is = 1
            Me.txtToDate.Enabled = True
            txtFromDate.SetFocus
    End Select


    'When you set the variable here, the user hasn't had opportunity to enter into the textbox; move it to cmdRun
    'Also textbox will have a string, and variable is declared as Date; should use cdate(txtToDate.Value)
    'toDate = txtToDate.Value
End Sub




Private Sub cmdRun_Click()
' Since the user can change options right up to the Commit/Run then
' the Run button should do all the final variable validation/assignment


    If cboFromDate.ListIndex = 3 Then
        If Not IsDate(Me.txtFromDate.Value) Then
            MsgBox "Invalid input. Please enter a date.", vbExclamation, "Outlook Report"
            Me.txtFromDate.SetFocus
            Exit Sub
        Else
            fromDate = CDate(txtFromDate.Value)


            If cboToDate.ListIndex = 1 Then
                If Not IsDate(Me.txtToDate.Value) Then
                    MsgBox "Invalid input. Please enter a date.", vbExclamation, "Outlook Report"
                    Me.txtToDate.SetFocus
                    Exit Sub
                Else
                    toDate = CDate(txtToDate.Value)
                End If
            End If
        End If
    End If


    Call getOutlookInfo(fromDate, toDate)


    Unload Me
End Sub

 

[ricciolo]

Thanks so much!

If I wanted to add a function so that I could check whether the user entered the date in the correct format, would it be okay to add it in the Userform code? Or would it be better to add it to a module since the function doesn't necessarily correspond with anything I added to the userform (i.e., a button-click, etc.)?

 

[ricciolo]

Also, while I was debugging, I noticed that txtFromDate.Value and txtToDate.Value return 12:00:00 AM as dates if I choose the pre-caculated options (30 days before, etc.) in the Userform.

Do you have any idea for why this might be happening?

 

[ricciolo]

Also, while I was debugging, I noticed that txtFromDate.Value and txtToDate.Value return 12:00:00 AM as dates if I choose the pre-caculated options (30 days before, etc.) in the Userform.

Okay, after some more investigation, I realized that what I wrote above is incorrect. What I did was:

Debug.Print "fromDate = " & fromDate

and got 12:00:00 AM and txtFromDate.Value gives a formatted date (mm/dd/yyyy).

 

[ricciolo]

Never mind; I was able to find the error. It has to do with where I assigned toDate and fromDate. Also, I decided not to do a check-format function because I could use the Format function in case the user enters "mm/dd/yy".

Sorry again for so many posts!

 

[tweedle]

you're doing ok then, I think.

Sorry for not responding earlier; can't post from work or they could attempt to claim the 'intellectual property'. pthh.

 

[ricciolo]

Thanks again for your help! I got the userform working as I wanted.

 

[ricciolo]

Actually, I have a follow-up question. I'm not sure if it would be better to start a new thread but since the code is related to this topic, I thought it would be safer to just add it this thread.

I have the following code for getOutlookData():

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


Sub getOutlookInfo(fromDt As Date, toDt As Date)
    'On Error GoTo ErrHandler
    
    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
  
    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
    
'ErrHandler:
'    If Err.Number <> 0 Then
'    MsgBox "ERROR: " & Err.Number & ": " & Err.Description, vbExclamation, "Outlook Reporting Error"
'        Exit Sub
'    End If
    
End Sub


Sub RecursiveFolders(olFolder As Object)
    Dim olSubFolder As Object
    Dim olMail As Object
    Dim compareDt As Date
    Dim olItems As Object
    Dim index As Integer
    
    'folders to skip
    Select Case olFolder.Name
        Case "Sync Issues"
            Exit Sub
        Case "Drafts"
            Exit Sub
        Case "Calendar"
            Exit Sub
        Case "Contacts"
            Exit Sub
        Case "Journal"
            Exit Sub
        Case "Junk E-Mail"
            Exit Sub
        Case "Tasks"
            Exit Sub
    End Select
    
    'check to see which folders exist
    'MsgBox olFolder.Name
    
    'reorder the mail items in descending order
    Set olItems = olFolder.Items
    olItems.Sort ["SentOn"], True
    
    For Each olMail In olItems
    
        If TypeOf olMail Is MailItem Then
            compareDt = DateSerial(Year(olMail.ReceivedTime), Month(olMail.ReceivedTime), Day(olMail.ReceivedTime))
        
            'if the mail item isn't within date range, exit sub
            If (compareDt < sinceDt) Or (compareDt > untilDt) Then
                Exit Sub
            Else
                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
                
            End If
        End If
    Next
    
    For Each olSubFolder In olFolder.Folders
        Call RecursiveFolders(olSubFolder)
    Next olSubFolder
    
End Sub

As you can see, if the user chooses the "Draft" folder, the code exits. However, while I was testing, I noticed that if I choose the "Draft" folder, the code exits from RecursiveFolders() and continues in getOutlookInfo and by the time it reaches:

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

there's an "Subscript out of range" error.

I thought that I could prevent it by adding the line "If isEmpty(arrData) Then Exit Sub End If" (since arrData is uninitialized), but that doesn't work. Do you have any idea how I'm getting a subscript out of range error when the code hasn't even done anything with arrData?