How to reference group or shared calendar in Outlook 365 Exchange using Excel?

Question

I'm trying to have multiple users be able to add an appointment to a shared calendar using Excel.

The following code works for me. I own the shared calendar and it resides in my Calendar folder in Outlook365.

Sub CreateAppt()

Const olFolderCalendar = 9
Const olPublicFoldersAllPublicFolders = 18
Const olAppointmentItem = 1 '1 = Appointment


Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set items = objNameSpace.GetDefaultFolder(olFolderCalendar).items

'check to see if calendar exists
For i = 1 To objNameSpace.GetDefaultFolder(olFolderCalendar).Folders.Count

If objNameSpace.GetDefaultFolder(olFolderCalendar).Folders.Item(i).Name = "Maintenance Task Manager" Then

    'set calendar name and set new appointment
    Set objCalendar = objNameSpace.GetDefaultFolder(olFolderCalendar).Folders("Maintenance Task Manager")
    Set objapt = objCalendar.items.Add(olAppointmentItem)

    'create appointment for PM
    With objapt
        .Subject = "PM Due for " & ActiveSheet.Range(PMcell).Offset(0, -6).Value
        .Location = ActiveSheet.Range(PMcell).Value
        .AllDayEvent = True
        .Start = ActiveSheet.Range(PMcell).Value
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 10080
        If Not emailaddy = "" Then
            .Recipients.Add (emailaddy)
        End If
        .BusyStatus = olFree
        .Categories = "Equipment PM's"
        .body = PersonResponsible & ", you are responsible for the PM on this piece of equipment due on " & Format(DueDate, "Long Date")
    .Save
    End With
    Exit Sub
End If
Next i
End Sub

The code looks for a calendar called "Maintenance Task Manager" in the Calendar folder.

The problem is in other users' Outlook this folder is not in the Calendar folder and therefore cannot be found. It seems to not be in any folder.

Answer 1

It is obtained differently than the calendar folder.

Because it is a calendar shared by others.

You can see the following link to get this folder.

Access a Folder Opened from a Sharing Invitation

Answer 2

I ended up finding a solution that works great in my situation. I had to add a new group in Outlook365 and share it with my users with read/write permissions. After they accepted, they had to add the group calendar into their favourites.

The code for anyone interested is as follows.

Sub Test()

Const olFolderCalendar = 9
Const olModuleCalendar = 1
Const olAppointmentItem = 1
Dim answer As Integer
Dim objNS
Dim objExpCal
Dim objNavMod
Dim objNavGroup
Dim objNavFolder
Dim objFolder
Dim colExpl

Set oApp = CreateObject("Outlook.Application")
Set objNS = oApp.Session
Set colExpl = oApp.Explorers
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)

For Each objNavGroup In objNavMod.NavigationGroups
    For Each objNavFolder In objNavGroup.NavigationFolders
        If Not objNavFolder = "SHARED CALENDAR NAME" Then '<<must be named exactly as in the nav pane in outlook
            GoTo NxtGroup
        End If
        On Error Resume Next
        Set objFolder = objNavFolder.Folder

NxtGroup:
    Next
Next

Set objCalendar = objFolder
Set objapt = objCalendar.items.Add(olAppointmentItem)

    'create an appointment to schedule PM with outside contractor
    With objapt
        .Subject = "SUBJECT HERE"
        .Location = "LOCATION HERE
        .AllDayEvent = True 'or comment out and add an .End = line
        .Start = "SOME DATE HERE"
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 10080
        .BusyStatus = olFree
        .Categories = "MUST HAVE SOMETHING HERE TO BE ABLE TO DELETE THE EVENT IF NEEDED"
        .body = ""
        .Display 'or .Save
    End With

Set objNS = Nothing
Set objNavMod = Nothing
Set objNavGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set colExpl = Nothing

End Sub