将约会保存到 Exchange 公共日历文件夹答案

【问题标题】：Save Appointment to Exchange Public Calendar Folder将约会保存到 Exchange 公共日历文件夹
【发布时间】：2019-07-10 13:46:10
【问题描述】：

我想在 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

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

【问题讨论】：

标签： vba outlook calendar

【解决方案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

【讨论】：