为共享日历创建 MS Outlook 约会

Question

最近我处理了为我自己的日历创建 MS Outlook 约会：

VBA Excel synchronising the date cells with Outlook calendar events

现在我想让它在整个公司共享的日历中运行。

当我切换到共享日历（位于 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")

根据以下链接中的提示：

Extracting appointments from shared Outlook calendar to 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