Accessing Custom Outlook Calendar Entries

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

user_1140579 · Answer

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

Accessing Custom Outlook Calendar Entries

1 Answers