How to Add an Appointment to a Shared Calendar in Outlook? - vba

Question

I am attempting to create an appointment taken from a .CSV file with Subject and Date and place this in someone else's shared calendar.
I have full editor's permissions for this shared calendar. By shared calendar I mean, a regular calendar made in the person's Outlook and clicking "Share" and emailing it to others.
Sub ImportAppointments(full_path As String)
'Initialize variables
Dim exlApp As Excel.Application
Dim exlWkb As Workbook
Dim exlSht As Worksheet
Dim rng As Range
Dim itmAppt As Outlook.AppointmentItem
' Create reference to Excel
Set exlApp = New Excel.Application
' Select file path, currently hardcoded to one directory, change as needed
Dim strFilepath As String
'strFilepath = "P:\Holiday Calendar\Holiday_Calendar_Data.csv"
strFilepath = full_path
' Select workbook (the above .csv file) and select the first worksheet as the data sheet
Set exlSht = Excel.Application.Workbooks.Open(strFilepath).Worksheets(1)
' Initialize variables
Dim iRow As Integer
Dim iCol As Integer
Dim oNs As Namespace
Dim olFldr As Outlook.MAPIFolder
Dim objOwner As Outlook.Recipient
' Allow accessing data stored in the user's mail stores in Outlook
Set oNs = Outlook.GetNamespace("MAPI")
' Set share calender owner
Set objOwner = oNs.CreateRecipient("calvin#xyz.ca")
objOwner.Resolve
If objOwner.Resolved Then
' Set up non-default share folder location
Set olFldr = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Folders("Holiday Calendar")
End If
' Start point
iRow = 2
iCol = 1
' Loop through each calendar entry
While exlSht.Cells(iRow, 1) <> ""
Set itmAppt = Outlook.CreateItem(olAppointmentItem)
' Set appointment Subject, ie (Vacation, Sick Day, Half-Day, etc.)
itmAppt.Subject = exlSht.Cells(iRow, 1)
' Set Date of Event
itmAppt.Start = exlSht.Cells(iRow, 2)
' Force All Day Event
itmAppt.AllDayEvent = True
' Save appointment
itmAppt.Save
' Advance pointer to next row
iRow = iRow + 1
' Transfer appointment into shared calendar folder
itmAppt.Move olFldr
Wend
' Close everything
Excel.Application.Workbooks.Close
exlApp.Quit
Set exlApp = Nothing
Set olFldr = Nothing
Set itmAppt = Nothing
End Sub
My code fails to find the "Holiday Calendar" if I try to insert at someone else's calendar with
Set olFldr = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Folders("Holiday Calendar")

Answer 1

Instead of calling Application.CreateItem / AppointmentItem.Move, create the item directly using olFldr.Items.Add.

Answer 2

This line of code is slightly off if the calendar you are writing to is at the same folder level as the default calendar:
Set olFldr = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Folders("Holiday Calendar")
Instead, you need to specify .Parent before the .Folders property
Set olFldr = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Parent.Folders("Holiday Calendar")
I derived this answer from: https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/

Answer 3

Sharing this as it took me ages to come up with a solution to add a calendar meeting request from an Exchange Shared Mailbox.
This code creates, displays and pre-fills an appointment which will be saved in the Shared Mailbox, and if sent to other recipients will appear to the recipient as being sent from the shared mailbox account!
Sub SendEmailFromSharedMailbox()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Dim olNS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
Set olNS = olApp.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("Shared Mailbox Name")
objOwner.Resolve
If objOwner.Resolved Then
MsgBox objOwner.Name
Set newCalFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
'Now create the email
Set olAppt = newCalFolder.Items.Add(olAppointmentItem)
With olAppt
'Define calendar item properties
.Start = "19/9/2019 2:00 PM"
.End = "19/9/2019 2:30 PM"
.Subject = "Appointment Subject Here"
.Recipients.Add ("someone#email.com")
'Add more variables as required, eg reminder, importance, etc
.Display
End With
End If
End Sub