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

Copper Contributor

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 If
End With
End Sub

 

 

 


Unfortunately 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

0 Replies