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

31330

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