CODEWITHSUNDEEP
vbaoutlookcalendar
DevonRyder
DevonRyder

Reputation: 193

Save Appointment to Exchange Public Calendar Folder

I would like to save and share important items across user accounts running on an Exchange 2016 server. This is setup via Public Folders on the server.

How do I specify the appointment items created go to the folder in the root public folder that is designated for calendar items?

I created all the necessary public folder items on the Exchange 2016 server and have them appearing across multiple accounts that have been designated the required permissions.

I have the appointment item populated with some basic information and I would like it to go to said folder once the user populates any additional fields and clicks the save/send button.

The folder structure for the public folders:

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

If I manually send/save the item, it does not appear in the folder, and it also doesn't appear in the user's calendar.

Upvotes: 2

Views: 536

Answers (1)

Asger
Asger

Reputation: 3877

Instead of creating a "lonely" appointment item, try to create an additional item within the appropriate calendar instead:

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

As the code row Set objMsg = Application.ActiveExplorer().Selection(1) only works, if the user currently selected an email item, I suggest to verify that additionally:

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

Upvotes: 2

Related Questions