Outlook VBA将约会保存到Exchange公共日历文件夹

Question

我正在为一家希望能够在其用户帐户中保存和共享重要项目的公司编写一些适用于Outlook的VBA宏。在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 objDKRRFolder As Outlook.Folder
    Dim objApptFolder As Outlook.Folder

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

    With objCalAppt
        .MeetingStatus = olNonMeeting 'Not an invitation
        .Subject = objMsg.Subject
        .Start = objMsg.SentOn
        .Duration = 120
    End With

    objCalAppt.Display
End Sub

如果我尝试简单地手动发送/保存项目，它似乎没有出现在文件夹中，它似乎也没有出现在用户日历中。

Answer 1

而不是创建“孤独”约会项目，尝试在相应的日历中创建一个额外的项目：

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().Selection(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