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
