Creating MS outlook appointment for shared calendars

Question

Recently I was dealt with creating MS Outlook appointments for my own calendars:

VBA Excel synchronising the date cells with Outlook calendar events

Now I would like to make it running for the calendar, which is shared across the company.

When I switch to the shared calendar (the calendar folder located externally to my Outlook), then i am getting error like this:

My code looks as follows:

 Sub CalendarOutlookScheduleMail()

 Dim objOutlook As Outlook.Application
 Dim OutlookMail As Outlook.MailItem
 Dim objNamespace As Outlook.Namespace
 Dim items As Outlook.items
 Dim objCalendar As Outlook.Folder, objapt As Outlook.AppointmentItem
 Dim Sbj As String, Job As String
 Dim Unit As Integer
 Dim Dt As Date
 Dim dtr As Range
 Job = ThisWorkbook.Sheets("Sheet1").Range("AB2")
 Sbj = ThisWorkbook.Sheets("Sheet1").Range("AB4")


 Dt = DateValue(dtr)

 Const olFolderCalendar = 9
 Const olAppointmentItem = 1 '1 = Appointment

 Set objOutlook = CreateObject("Outlook.Application")
 Set OutlookMail = objOutlook.CreateItem(olMailItem)
'Set calFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)


 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set items = objNamespace.GetDefaultFolder(olFolderCalendar).items

 Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("MDU VM") 'target calendar 
  Survey
 Set items = objCalendar.items
 Set objapt = items.add(olAppointmentItem)


 objapt.Subject = Sbj '"Test" 'Owner
 objapt.Start = Dt + TimeValue("09:00:00")
 objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
 objapt.End = Dt + TimeValue("17:30:00")
 objapt.Save
End Sub

I swept the line:

  Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("MDU VM") 

with

 Set objCalendar = objNamespace.GetSharedDefaultFolder(olFolderCalendar).Folders("MDU VM")

according to hints in the links below:

Extracting appointments from shared Outlook calendar to Excel

https://docs.microsoft.com/en-us/office/vba/api/outlook.namespace.getshareddefaultfolder

but now I am getting an error: Type mismatch

I think I used the GetSharedDefaultFolder on wrong way.

Can anyone help me?

I want to have this code running also for shared outlook calendars.

Answer 1

The NameSpace.GetSharedDefaultFolder function returns a Folder object that represents the specified default folder for the specified user and takes two parameters. For example:

Sub ResolveName()  
 Dim myNamespace As Outlook.NameSpace  
 Dim myRecipient As Outlook.Recipient  
 Dim CalendarFolder As Outlook.Folder 

 Set myNamespace = Application.GetNamespace("MAPI")  
 Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")  
 myRecipient.Resolve  
 If myRecipient.Resolved Then  
   Call ShowCalendar(myNamespace, myRecipient)  
 End If  
End Sub 

Sub ShowCalendar(myNamespace, myRecipient)  
 Dim CalendarFolder As Outlook.Folder 
 Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)  
 CalendarFolder.Display  
End Sub