Using a Macro to send data to shared Outlook Calendars

Hello,

I am currently setting up a spreadsheet for my office in which we can enter appointments and use a macro to send them to someone's calendar by selecting their name. I currently have this working and sending to calendars that I have made myself but I am stuck with how to send the data to other people. Currently, my macro looks like this:

Option Explicit
Public Sub CreateOutlookApptz()
   Sheets("Sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder
    Dim arrCal As String
    
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
    arrCal = Cells(i, 1).Value
    Set subFolder = CalFolder.Folders(arrCal)
     If Trim(Cells(i, 11).Value) = "" Then
    Set olAppt = subFolder.Items.Add(olAppointmentItem)
         
    

    With olAppt
    
    
        .Start = Cells(i, 5)
        .End = Cells(i, 12)
        .Subject = Cells(i, 2)
        .Location = Cells(i, 3)
        .Body = Cells(i, 4)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 7)
        .ReminderSet = True
        .Save
    
    End With
    Cells(i, 11) = "Imported"
    
    End If
                
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     ThisWorkbook.Save
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

In which arrCal is a dropdown field that is currently set to go to test calendars that I have made myself. Any help in this would be greatly appreciated as I have been struggling with this for most of the day. If anyone needs any further information about the spreadsheet feel free to ask.

Thanks,

Neilp27

You can use the Namespace.GetSharedDefaultFolder method to access the Calendar folder in another Exchange mailbox - as long as you, or more to the point, the current user has permissions (in Outlook) to do so.

Code snippet - this temporarily creates an email message so it can resolve the addressee to get the correct calendar

    strName = "DoeJ"
     
    Set oApp = CreateObject("Outlook.Application")
    Set oNS = objApp.GetNamespace("MAPI")
    Set oDummy = objApp.CreateItem(olMailItem)
    Set oRecip = oDummy.Recipients.Add(strName)
    oRecip.Resolve
    If oRecip.Resolved Then
        On Error Resume Next
        Set oFolder = _
          oNS.GetSharedDefaultFolder(oRecip, _
            olFolderCalendar)
        If Not oFolder Is Nothing Then
            Set oAppt = objFolder.Items.Add
            If Not oAppt Is Nothing Then
                With oAppt
                    .Subject = "Test"
                    .Start = Date + 7
                    .AllDayEvent = True
                    .Save
                End With

Partial code only to illustrate the idea, that will not compile.