Listing calendar names of all active calendars

Question

I'm trying to list all the calendar names in Outlook (my own and shared calendars).

dim oApp
dim oNameSpace
dim oFolder
dim fChild
dim fParent
dim sNames

  fChild = Folder
  fParent = Folder
  sNames = ""
  set oApp = CreateObject("Outlook.Application")
  set oNameSpace = oApp.GetNamespace("MAPI")

  for each fParent in oNameSpace.Folders
    for each fChild in fParent.Folders
      if fChild.DefaultItemType = 9 then 
        sNames = sNames & fParent.Name & " -- " & fChild.Name & vbCrLf  
      end If
    next
  next
MsgBox(sNames) 

Am I on the right track?

Answer 1

Tou can use the NavigationModule object to iterate through all the groups of folders. Typically you could use objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup), but if the user has added groups of calendars manually then this won't get you all the calendars. Also it's possible that permissions prevent accessing the folder programmatically; the code below allows for this.

const olFolderCalendar = 9
const olModuleCalendar = 1
Dim objOL 
Dim objNS 
Dim objExpCal 
Dim objNavMod 
Dim objNavGroup 
Dim objNavFolder 
Dim objFolder 
Dim colExpl 
dim s

s = ""
set oApp = CreateObject("Outlook.Application")
Set objNS = oApp.Session
Set colExpl = oApp.Explorers
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
For Each objNavGroup In objNavMod.NavigationGroups
    For Each objNavFolder In objNavGroup.NavigationFolders
        On Error Resume Next
        Set objFolder = objNavFolder.Folder
        If Err = 0 Then
            s = s & objNavGroup.Name & " -- " & left(objFolder.FolderPath,30) & vbcrlf
        Else
            s = s & objNavGroup.Name & " -- " & objNavFolder.DisplayName & " [no permission]" & vbcrlf
        End If
        On Error GoTo 0
    Next
Next
Set oApp = Nothing
Set objNS = Nothing
Set objNavMod = Nothing
Set objNavGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set colExpl = Nothing
msgbox s

In VBA:

Sub IterateAllCalendars()
    Dim s As String
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.namespace
    Dim objExpCal As Outlook.Explorer
    Dim objNavMod As Outlook.CalendarModule
    Dim objNavGroup As Outlook.NavigationGroup
    Dim objNavFolder As Outlook.NavigationFolder
    Dim objFolder As Outlook.Folder
    Dim colExpl As Outlook.Explorers

    s = ""
    Set objOL = Application
    Set objNS = objOL.Session
    Set colExpl = objOL.Explorers
    Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    For Each objNavGroup In objNavMod.NavigationGroups
        For Each objNavFolder In objNavGroup.NavigationFolders
            On Error Resume Next
            Set objFolder = objNavFolder.Folder
            If Err = 0 Then
                s = s & objNavGroup.Name & " -- " & Left(objFolder.FolderPath, 30) & vbCrLf
            Else
                s = s & objNavGroup.Name & " -- " & objNavFolder.DisplayName & " [no permission]" & vbCrLf
            End If
            On Error GoTo 0
        Next
    Next
    Set objOL = Nothing
    Set objNS = Nothing
    Set objNavMod = Nothing
    Set objNavGroup = Nothing
    Set objNavFolder = Nothing
    Set objFolder = Nothing
    Set colExpl = Nothing
    MsgBox s
End Sub