Reference a non-default calendar to add items in a loop

Question

I came across this macro that sends a task in MS Project to MS Outlook.

The code creates an appointment in my default calendar.

Sub Export_Selection_To_OL_Appointments()
Dim myTask As Task
Dim myItem As Object
    
On Error Resume Next
Set myOLApp = CreateObject("Outlook.Application")
  
For Each myTask In ActiveSelection.Tasks
    Set myItem = myOLApp.CreateItem(1)
    With myItem
        .Start = myTask.Start
        .End = myTask.Finish
        .Subject = " Rangebank PS " & myTask.Name
        .Categories = myTask.Project
        .Body = myTask.Notes
        .Save
    End With
Next myTask

End Sub

I want to create an appointment within a different calendar.

I was provided this as a way to reference a non default calendar.

Option Explicit

Sub NonDefaultFolder_Add_Not_Create()

Dim myOlApp As Object
Dim myDefaultStore As Object

Dim nonDefaultCalendar As Object
Dim myItem As Object

On Error Resume Next
Set myOlApp = CreateObject("Outlook.Application")

' Consider this mandatory.
' Limit the scope of the error bypass to the minimum number of lines.
' Ideally the scope is zero lines.
On Error GoTo 0

If Not myOlApp Is Nothing Then

    Set myDefaultStore = myOlApp.Session.defaultStore
    Debug.Print myDefaultStore
    
    ' This references a calendar on the same level as the default calendar
    Set nonDefaultCalendar = myOlApp.Session.Folders(myDefaultStore.DisplayName).Folders("Calendar Name")
    nonDefaultCalendar.Display
    
    ' Add to non-default folders (or create in the default then copy or move)
    Set myItem = nonDefaultCalendar.Items.Add
    With myItem
        .Subject = " Rangebank PS "
        .Display
    End With

Else
    MsgBox "Error creating Outlook object."
    
End If

End Sub

I tried this.

Option Explicit

Sub NonDefaultFolder_Add_Not_Create()
Dim myTask As Task
Dim myItem As Object
Dim myOLApp As Object
Dim myDefaultStore As Object
Dim nonDefaultCalendar As Object
On Error Resume Next
Set myOLApp = CreateObject("Outlook.Application")
  
For Each myTask In ActiveSelection.Tasks
    Set myItem = myOLApp.CreateItem(1)
    With myItem
        .Start = myTask.Start
        .End = myTask.Finish
        .Subject = " Rangebank PS " & myTask.Name
        .Categories = myTask.Project
        .Body = myTask.Notes
        .Save

On Error GoTo 0

If Not myOLApp Is Nothing Then

    Set myDefaultStore = myOLApp.Session.DefaultStore
    Debug.Print myDefaultStore
    
    Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")
    nonDefaultCalendar.Display
    
    ' Add to non-default folders (or create in the default then copy or move)
    Set myItem = nonDefaultCalendar.Items.Add
    With myItem
        .Subject = " Rangebank PS "
        .Display
    End With
    End If

End With
End Sub

I get:

"Compile error: For without next"

It highlights End Sub.

Adding Next before End Sub fixed that issue but it won't find the custom calendar:

"Run-time error '-2147221233 (8004010f)': The attempted operation failed. An Object could not be found.

It then highlights

Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")

The name of the calendar is correct so its not a typo.

Answer 1

You may find the NameSpace.GetSharedDefaultFolder method helpful, it is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder).

Also you can get the default calendar folder (or the parent folder) and try to iterate over all subfolders to find the required one. Or just navigating through the tree of folders in Outlook, for example:

OutlookApp.Session.Folders(yourDefaultStore.DisplayName).Folders("Calendar Name")

The sequence of property and method calls depends on the actual folder location.