I came across this macro which is working fine thus far. What it does is that it sends a task in MS Project to MS Outlook as a new appointment to add to my Outlook 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


The code currently creates an appointment in my default Calendar but I wanted for it to create an appointment within a different calendar with a different name. I sought help else where and was provided this as a way to reference a non default calendar, which is below

 
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 am very much a novice and wassnt sure where I was supposed to add the above into the original code so 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


Ive highlighted the original code in blue and the name of the custom calendar in red. But this doesnt work as I get this error


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


It highlights this as the error

Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")
If it helps this is where the B2A project Calendar appears in outlook

calendr.jpg

So its a calendar I created and then I share it with my other team members.

Any help would be greatly appreciated!

Thanks