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

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

1 个答案: