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