Getting reccuring appointments VBA - excel

Question

Can somebody please help me out. I have this code and it reads all appointments from the calendar for specific dates; however, the code doesn't display any recurring meetings within given dates:
ToDate = CDate("10/12/2019")
FromDate = CDate("10/06/2019")
'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
'include reccuring items
'-------------------------
olFolder.Items.Sort ("[Start]")
olFolder.Items.IncludeRecurrences = True
'-------------------------
NextRow = 2
With Sheets("Sheet1") 'Change the name of the sheet here
.Range("A1:F1").Value = Array("Report Date", "Date", "Time spent", "Location", "Categories", "Title")
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(NextRow, "A").Value = Format(Now, "DD-MM-YY")
.Cells(NextRow, "B").Value = CDate(olApt.Start)
.Cells(NextRow, "C").Value = olApt.End - olApt.Start
.Cells(NextRow, "C").NumberFormat = "HH:MM"
.Cells(NextRow, "E").Value = olApt.Categories
.Cells(NextRow, "F").Value = olApt.Subject
NextRow = NextRow + 1
Else
End If
Next olApt
.Columns.AutoFit
End With
Can somebody please help me out and let me know what I am doing wrong?!
Thank you!

Answer 1

Items in a folder have to be made into a collection to then manipulate.
On Error Resume Next ' This is a rare proper use.
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 itmCollection = olFolder.Items
'include recurring items
'-------------------------
itmCollection.Sort ("[Start]")
itmCollection.IncludeRecurrences = True
'-------------------------
For Each olApt In itmCollection
Demo code
Option Explicit
Sub apptsInDateRangeIncludingRecurrences()
Dim ToDate As Date
Dim FromDate As Date
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim itmCollection As Object
Dim itmCollectionFrom As Object
Dim itmCollectionFromTo As Object
Dim sFilter As String
Dim olApt As Object
ToDate = CDate("10/12/2019")
FromDate = CDate("10/06/2019")
On Error Resume Next ' This is a rare proper use.
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 itmCollection = olFolder.Items
'include recurring items
'-------------------------
itmCollection.Sort ("[Start]")
itmCollection.IncludeRecurrences = True
'-------------------------
'Filter for applicable items
sFilter = "[Start]>='" & FromDate & "'"
'Debug.Print sFilter
Set itmCollectionFrom = itmCollection.Restrict(sFilter)
sFilter = "[Start]<='" & ToDate & "'"
'Debug.Print sFilter
Set itmCollectionFromTo = itmCollectionFrom.Restrict(sFilter)
For Each olApt In itmCollectionFromTo
If olApt.Start >= FromDate Then
Debug.Print olApt.Start & " " & olApt.Subject
End If
Next olApt
Debug.Print "Done."
End Sub