VBA Shared Calendar Meeting Creator - excel

Question

I am using a modified code I found online, and I am having issues finding a shared calendar in outlook.
Sub SharedCalendarEventCreator()
Dim olApp As Outlook.Application
Dim outNameSpace As Namespace
Dim outSharedName As Outlook.Recipient
Dim outCalendarFolder As MAPIFolder
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim eduSheet As Worksheet
On Error Resume Next
Worksheets("Schedule").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set outNameSpace = olApp.GetNamespace("MAPI")
Set outCalendarFolder = outNameSpace.Folders("Lunch Calendar")
Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)
r = 7
Do Until Trim$(Cells(r, 1).Value) = ""
With olAppItem
.Subject = "SOF " & Cells(1, 2).Value & " " & Cells(2, 2).Value & " " & Cells(3, 2).Value & " " & Cells(r, 2).Value
.Start = Cells(r, 1).Value
vArray = Split(Cells(4, 2).Value2, ";")
For Each vElement In vArray
'.Recipients.Add .Recipients.Add(vElement)
Next vElement
.MeetingStatus = olMeeting
.AllDayEvent = True
.Body = Cells(r, 3).Value
.ResponseRequested = False
.Send
r = r + 1
End With
Loop
Set olAppItem = Nothing
Set outCalendarFolder = Nothing
Set outNameSpace = Nothing
Set olApp = Nothing
End Sub
Picture of the Calendar location:
I believe the issue is within these lines, but I have tried to change them without any luck:
Set outNameSpace = olApp.GetNamespace("MAPI")
Set outCalendarFolder = outNameSpace.Folders("Lunch Calendar")
Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)
The error I received:
When I hit debug, this is the line it highlights:
Any help is greatly appreciated.

Answer 1

Navigate the folder tree from "janedoe#gmail" to "Calendar" to "Lunch Calendar".
Option Explicit
Sub SharedCalendarEventCreator()
' Early binding - Set reference to Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim outNameSpace As Outlook.Namespace
Dim outMailboxFolder As Outlook.Folder
Dim outCalendarFolder As Outlook.Folder
Dim outCalendarSubFolder As Outlook.Folder
Dim olAppItem As Outlook.AppointmentItem
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set outNameSpace = olApp.GetNamespace("MAPI")
Set outMailboxFolder = outNameSpace.Folders("janedoe#gmail")
Set outCalendarFolder = outMailboxFolder.Folders("Calendar")
Set outCalendarSubFolder = outCalendarFolder.Folders("Lunch Calendar")
'Set ActiveExplorer.CurrentFolder = outCalendarSubFolder
Set olAppItem = outCalendarSubFolder.Items.Add(olAppointmentItem)
olAppItem.Display
Set olAppItem = Nothing
Set outCalendarSubFolder = Nothing
Set outCalendarFolder = Nothing
Set outMailboxFolder = Nothing
Set outNameSpace = Nothing
Set olApp = Nothing
End Sub