Outlook VBA Сохранить встречу в папке общего календаря Exchange - PullRequest
Новая
       29

Outlook VBA Сохранить встречу в папке общего календаря Exchange

0 голосов
/ 16 февраля 2019

Я пишу несколько макросов VBA для Outlook для компании, которая хотела бы иметь возможность сохранять и делиться важными элементами в своих учетных записях пользователей.работает на сервере 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

, если я попытаюсь просто вручную отправить / сохранить элемент, он не отображается впапка, и она также не появляется в календаре пользователей.

1 Ответ

0 голосов
/ 19 февраля 2019

Вместо создания «одинокого» элемента встречи попробуйте создать дополнительный элемент в соответствующем календаре: 

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
...