Accessing Custom Outlook Calendar Entries - excel

Question

I'm trying to access calendar entries from 2 custom Outlook calendars using Excel VBA.
I've obtained some code which gives me what I want from the default calendar but I cannot see how to change the location to my own calendars.
The code I'm using is
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim nextrow As Long
Dim FromDate As Date
Dim ToDate As Date
FromDate = CDate("30/11/2021")
ToDate = CDate("20/12/2021")
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)
nextrow = 2
With Sheets("Cal-Ext")
.Range("A1:E1").Value = Array("Date", "Start Time", "End Time", "Subject", "Location")
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = nextrow + 5
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
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
I need to change the set olfolder command before the second loop to select my own calendar but nothing I've tried works.
Outlook calendar
Current excel result

Answer 1

Here is a quick code that I wrote to loop through all the navigation folders of My Calendars
This code was tested in MS Outlook. You may have to edit it for it to work in MS Excel.
Option Explicit
Sub Sample()
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = Outlook.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
Screenshot
Code from Excel
Option Explicit
Sub ListAppointments()
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = OutApp.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub