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
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