Save Appointment to Exchange Public Calendar Folder - vba

Question

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:
All Public Folders
Company Name sub-folder (Public Folder Mailbox)
Mail
Contacts
Calendars
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.

Answer 1

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