Создание встречи MS outlook для общих календарей

Question

Недавно я занимался созданием встреч MS Outlook для моих собственных календарей:

VBA Excel, синхронизирующий ячейки даты с событиями календаря Outlook

Теперь я хотел бы заставить его работать для календаря, который является общим для всей компании.

Когда я переключаюсь на общий календарь (папка календаря, расположенная за пределами моего Outlook), я получаю такую ​​ошибку:

Мой код выглядит следующим образом:

 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

Я прокрутил строку:

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

с

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

согласно подсказкам в ссылках ниже:

Извлечение встреч из общего календаря Outlook в Excel

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

, но теперь я получаю сообщение об ошибке: Несоответствие типов

Думаю, я неправильно использовал GetSharedDefaultFolder.

Кто-нибудь может мне помочь?

Я хочу, чтобы этот код работал и для общих календарей Outlook.

Answer 1

Функция NameSpace.GetSharedDefaultFolder возвращает объект Folder, который представляет указанную папку по умолчанию для указанного пользователя и принимает два параметра. Например:

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