Export Outlook to Excel and Filter by Categories

[Davew001]

Hello. I'm using some code I found on another thread (below) to export appointments from Outlook to Excel to use as a simple timesheet. I made minor modifications and It works well, but I have limited experience with VBA and would greatly appreciate your help with a few simple enhancements.

In priority order, I'd like help with...

1. the ability to only export appointments that have a specific Outlook category assigned to them (e.g., "04 Client XYZ").

2. group appointments by date and show a total duration for each date in the output

3. show an overall total of the number of hours works

4. a simple text input box for the function dates and the category so I don't need to manually update them in the code. I only need to select a single category for each run.

Thanks in advance for your help!

Option Explicit

Dim bWeStartedOutlook As Boolean

Private Function GetCalData(StartDate As Date, Optional EndDate As Date) As Boolean
    ' Exports calendar information to Excel worksheet
    ' -------------------------------------------------
    ' Notes:
    ' If Outlook is not open, it still works, but much
    ' slower (~8 secs vs. 2 secs w/ Outlook open).
    ' End Date is optional, if you want to pull from
    ' only one day, use: Call GetCalData("7/14/2008")
    ' -------------------------------------------------
    
    Dim ThisAppt As Object ' Outlook.AppointmentItem
    Dim MyItem As Object
    Dim StringToCheck As String
    Dim i As Long
    
    ' if no end date was specified, then the requestor
    ' only wants one day, so set EndDate = StartDate
    ' this will let us return appts from multiple dates,
    ' if the requestor does in fact set an appropriate end date
    If EndDate = "12:00:00 AM" Then
        EndDate = StartDate
    End If
    
    If EndDate < StartDate Then
        MsgBox "Those dates seem switched, please check" & _
        "them and try again.", vbInformation
        GoTo ExitProc
    End If
    
    ' get Outlook
    Dim olApp As Object '  Outlook.Application
    Set olApp = GetOutlookApp
    If olApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        GoTo ExitProc
    End If
    
    ' get default Calendar
    Dim olNS As Object ' Outlook.Namespace
    Dim myCalItems As Object ' Outlook.Items
    Set olNS = olApp.GetNamespace("MAPI")
    Set myCalItems = olNS.GetDefaultFolder(9).Items ' olFolderCalendar
    
    ' ------------------------------------------------------------------
    ' the following code adapted from:
    ' http://www.outlookcode.com/article.aspx?id=30
    '
    With myCalItems
        .Sort "[Start]", False
        .IncludeRecurrences = True
    End With
    '
    StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & _
        " AND [End] <= " & Quote(EndDate & " 11:59 PM")
    Debug.Print StringToCheck
    '
    Dim ItemstoCheck As Object ' Outlook.Items
    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
    Debug.Print ItemstoCheck.Count
    ' ------------------------------------------------------------------
    
    If ItemstoCheck.Count > 0 Then
        ' we found at least one appt
        ' check if there are actually any items in the collection,
        ' otherwise exit
        If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
        
        ' set up worksheet
        Dim MyBook As Excel.Workbook
        Dim xlSht As Excel.Worksheet
        Dim rngStart As Excel.Range
        Dim rngHeader As Excel.Range
    
        Set MyBook = ThisWorkbook
        Set xlSht = MyBook.Sheets(1)
        Set rngStart = xlSht.Range("A1")
        Set rngHeader = Range(rngStart, rngStart.Offset(0, 6))
        
        ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
        ' http://support.microsoft.com/kb/306022
        rngHeader.Value = Array("Subject", "Start Date", "Start Time", "End Date", "End Time", "Duration (Hrs)", "Categories")
    
        ' create/fill array with exported info
        'Dim ColCount As Long
        'Dim arrData As Variant
        'ColCount = rngHeader.Columns.Count
        'ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
        
        Dim r As Long
        Dim outRecurrencePattern As Object
        
        r = 0
        For Each ThisAppt In ItemstoCheck
            r = r + 1
            rngStart.Offset(r, 0).Value = ThisAppt.Subject
            rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
            rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
            rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
            rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
            ' rngStart.Offset(r, 5).Value = ThisAppt.Location
            ' Dividing duration by 60 to get results in hours
            rngStart.Offset(r, 5).Value = ThisAppt.Duration / 60
            rngStart.Offset(r, 6).Value = ThisAppt.Categories
        
            If ThisAppt.IsRecurring Then
                
                'Loop through recurring events for this appointment
                
                Set outRecurrencePattern = ThisAppt.GetRecurrencePattern
                Do
                    Set ThisAppt = GetNextOccurrence(ThisAppt.Start, EndDate, outRecurrencePattern)
                    If Not ThisAppt Is Nothing Then
                        r = r + 1
                        rngStart.Offset(r, 0).Value = ThisAppt.Subject
                        rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                        rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
                        rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
                        rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
                        ' rngStart.Offset(r, 5).Value = ThisAppt.Location
                        rngStart.Offset(r, 5).Value = ThisAppt.Duration
                        rngStart.Offset(r, 6).Value = ThisAppt.Categories
                   End If
                Loop Until ThisAppt Is Nothing
            
            End If
        
            DoEvents
        Next
                
    Else
        MsgBox "There are no original appointments or meetings during" & _
            "the time you specified. Exiting now.", vbCritical
        GoTo ExitProc
    End If
    
    ' if we got this far, assume success
    GetCalData = True
    
ExitProc:
    If bWeStartedOutlook Then
olApp.Quit
    End If
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
End Function

Private Function GetNextOccurrence(ByVal startDateTime As Date, EndDate As Date, outRP As Object) As Object 'Outlook.AppointmentItem

    'Increment startDateTime by 1 day until a valid calendar appointment is found or the date exceeds endDate
    
    Do
        startDateTime = startDateTime + 1
        Set GetNextOccurrence = Nothing
        On Error Resume Next
        Set GetNextOccurrence = outRP.GetOccurrence(startDateTime)
        On Error GoTo 0
    Loop While GetNextOccurrence Is Nothing And Int(startDateTime) <= Int(EndDate)
    If Int(startDateTime) > Int(EndDate) Then Set GetNextOccurrence = Nothing
    
End Function

Private Function Quote(MyText)
    ' from Sue Mosher's excellent book "Microsoft Outlook Programming"
    Quote = Chr(34) & MyText & Chr(34)
End Function

Function GetOutlookApp() As Object
    On Error Resume Next
    Set GetOutlookApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set GetOutlookApp = CreateObject("Outlook.Application")
        bWeStartedOutlook = True
    End If
    On Error GoTo 0
End Function

Sub test()
    Dim success As Boolean
    ' success = GetCalData("2/1/2022", "2/12/2022")
    success = GetCalData(Date - 7, Date)
End Sub