Sending MS Project task to Outlook as an appoitnment in a custom calendar

[wntrh0lm]

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

[Charlize]

I don't have project so I couldn't test this but you can loop through the code with F8 to see what needs fixing.
Use it in a testing phase first.

Sub Export_Selection_To_OL_Appointments()
'project variables
'I used object because I don't have project
    Dim myTask As Object
'outlook variables
    Dim myOLApp As Object
    
    Dim Ns As Object
    Dim folder As Object
    Dim appt As Object
        
'setting up outlook for appointment in shared calendar
'myOLApp = outlook
'ns = outlooknamespace environment
    Set myOLApp = CreateObject("Outlook.Application")
    Set Ns = myOLApp.GetNamespace("MAPI")
'the shared calendar is part of your default calendar = folder of folder
'B2A Projects Calendar = name of shared calendar ?
    Set folder = Ns.GetDefaultFolder(olFolderCalendar).Folders("B2A Projects Calendar")
'appointment should be added to shared calendar
'so for every task in your selection we make an appointment in shared calendar
    For Each myTask In activeselection.Tasks
        Set appt = folder.items.Add
        With appt
            .Start = myTask.Start
            .End = myTask.Finish
            .Subject = " Rangebank PS " & myTask.Name
            .Categories = myTask.Project
            .Body = myTask.Notes
            .Display 'or .Save
        End With
        'clear the appt variable to accept new values for next myTask
        Set appt = Nothing
    Next myTask
'clear up variables
myOLApp = Nothing
End Sub

Charlize