Vba 将约会保存到Exchange公用日历文件夹

我希望在Exchange 2016服务器上运行的用户帐户之间保存和共享重要项目。这是通过服务器上的公用文件夹设置的

如何将创建的约会项目指定到根公用文件夹中为日历项目指定的文件夹

我在Exchange 2016服务器上创建了所有必需的公用文件夹项目，并使它们出现在多个已指定所需权限的帐户中

我已经用一些基本信息填充了约会项目，我希望在用户填充任何其他字段并单击“保存/发送”按钮后，它会转到所述文件夹

公用文件夹的文件夹结构：

• 所有公用文件夹
  • 公司名称子文件夹（公用文件夹邮箱）
    • 邮寄
    • 接触
    • 日历

如果我手动发送/保存项目，它不会出现在文件夹中，也不会出现在用户的日历中。

请尝试在相应的日历中创建其他项目，而不是创建“孤独”约会项目：

Public Sub CreateAppointment()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objMsg As Outlook.MailItem 'Message Object
    Dim objCalAppt As Outlook.AppointmentItem
    Dim objPublicFolderRoot As Outlook.Folder
    Dim objCompanyFolder As Outlook.Folder
    Dim objApptFolder As Outlook.Folder

    Set objNS = Application.GetNamespace("MAPI")
    Set objMsg = Application.ActiveExplorer().Selection(1)
    Set objPublicFolderRoot = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
    Set objCompanyFolder = objPublicFolderRoot.Folders("Company_Shared")
    Set objApptFolder = objCompanyFolder.Folders("Calendars")

    Set objCalAppt = objApptFolder.Items.Add(olAppointmentItem)
    With objCalAppt
        .MeetingStatus = olNonMeeting 'Not an invitation
        .Subject = objMsg.Subject
        .Start = objMsg.SentOn
        .Duration = 120
    End With

    objCalAppt.Display
End Sub

---

由于代码行

Set objMsg=Application.ActiveExplorer（）。选择（1）

仅起作用，如果用户当前选择了电子邮件项目，我建议另外验证：

Dim objSel As Outlook.Selection
Set objSel = Application.ActiveExplorer.Selection
If objSel.Count > 0 Then
    If objSel(1).Class = olMail Then
        Set objMsg = objSel(1)
    Else
        MsgBox "Works only on selected email."
    End If
Else
    MsgBox "Works only on selected email."
End If

Dim objSel As Outlook.Selection
Set objSel = Application.ActiveExplorer.Selection
If objSel.Count > 0 Then
    If objSel(1).Class = olMail Then
        Set objMsg = objSel(1)
    Else
        MsgBox "Works only on selected email."
    End If
Else
    MsgBox "Works only on selected email."
End If