Getting reccuring appointments VBA

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