Search code examples
excelvbaoutlook

Missing recurring meetings from others when exporting Outlook calendar to Excel via VBA


I've been poking around the various previously asked questions regarding this topic, but I'm stuck on one thing: when exporting my calendar from Outlook to Excel using a VBA in the target workbook, I'm missing recurring meetings originally set by others.

Here is the code I have. I have input boxes to limit the date range, and the IncludeRecurrences is working for "Appointment" type items I've set myself on my calendar. The code also correctly pulls non-recurring "Meetings" or "Teams meetings" set by both myself and others. What am I missing here? Should I being including another type in addition to "olApt"?

Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim olItems As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = Format(InputBox("Enter Start Date", , Date), "dd/mm/yyyy")
    ToDate = Format(InputBox("Enter End Date", , Date), "dd/mm/yyyy")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
    Set olItems = olFolder.Items
    NextRow = 3
    
    olItems.Sort "[Start]"
    olItems.IncludeRecurrences = True

    With Sheets("Sheet1") 'Change the name of the sheet here
        .Range("A2:C2").Value = Array("Subject", "Date", "Total Time")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

EDIT: Solved! Find/FindNext was indeed the solution, which was added to the block below.

olItems.Sort "[Start]"
    olItems.IncludeRecurrences = True
    Set currentAppointment = olItems.Find("[Start] >= """ & FromDate & """ and [Start] <= """ & ToDate & """")

    With Sheets("Sheet1") 'Change the name of the sheet here
        .Range("A2:C2").Value = Array("Subject", "Date", "Total Time")
        For Each currentAppointment In olItems
            If (currentAppointment.Start >= FromDate And currentAppointment.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = currentAppointment.Subject
                .Cells(NextRow, "B").Value = CDate(currentAppointment.Start)
                .Cells(NextRow, "C").Value = currentAppointment.End - currentAppointment.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                NextRow = NextRow + 1
                Set currentAppointment = olItems.FindNext
            Else
            End If
        Next currentAppointment
    End With

Solution

  • IncludeRecurrences only works with Items.Restrict or Find/FineNext if you restrict on a time range. You cannot possibly export all instances of recurring appointments - imagine patterns with no end date.

    See https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences