How can I send an Outlook invite from a shared mailbox using VBA?

I have been trying to setup a meeting invite from a shared mailbox using VBA.

It works with the personal mailbox but not the shared mailbox. I have full permission.

I think the problem lies in setting the outAccount.

Sub send_invites(r As Long)
    Dim OutApp As Outlook.Application
    Dim OutMeet As Outlook.AppointmentItem
    Set OutApp = Outlook.Application
    Set OutMeet = OutApp.CreateItem(olAppointmentItem)
    Dim OutAccount As Outlook.Account: Set OutAccount = OutApp.Session.Accounts.Item(1)

    With OutMeet
        .Subject = Cells(r, 1).Value
        .RequiredAttendees = Cells(r, 11).Value
        ' .OptionalAttendees = ""
    
        Dim sDate As Date: sDate = Cells(r, 2).Value + Cells(r, 3).Value
        Dim eDate As Date: eDate = Cells(r, 4).Value + Cells(r, 5).Value
            
        .Start = sDate
        .End = eDate
            
        .Importance = olImportanceHigh
            
        Dim rDate As Date: rDate = Cells(r, 7).Value + Cells(r, 8).Value
        Dim minBstart As Long: minBstart = DateDiff("n", sDate, eDate)
            
        .ReminderMinutesBeforeStart = minBstart
            
        .Categories = Cells(r, 9)
        .Body = Cells(r, 10)
            
        .MeetingStatus = olMeeting
        .Location = "Microsoft Teams"
            
        .SendUsingAccount = OutAccount
        .Send
    End With
    
    Set OutApp = Nothing
    Set OutMeet = Nothing
End Sub

Sub send_invites_click()
    Dim rg As Range: Set rg = shData.Range("A1").CurrentRegion
    Dim i As Long
    For i = 2 To rg.Rows.Count
        Call send_invites(i)
    Next i
End Sub

Solution

I figured that out

So, the way to go for shared MailBox is to identify the correct folder inside via user account and only then create the meetings.

SentOnBehalfOfName isn't a necessity, it seems.

For anyone with the seeking to solve this, here is the full code:

Sub send_invites_click()
        Dim rg As Range: Set rg = shData.Range("A1").CurrentRegion
        Dim i As Long
        For i = 2 To rg.Rows.Count
                Call send_meetings(i)
        Next i
End Sub


Sub send_meetings(r)

    Dim OutApp As Outlook.Application
    Set OutApp = CreateObject("Outlook.Application")
    
    Dim OutMail As Outlook.MailItem
    Set OutMail = OutApp.CreateItem(olMailItem)
    
    Dim SharedMailboxEmail As String
    SharedMailboxEmail = Range("sharedMail").Value
    
    Set outNameSpace = OutApp.GetNamespace("MAPI")
    Set outSharedName = outNameSpace.CreateRecipient(SharedMailboxEmail)
    Set outCalendarFolder = outNameSpace.GetSharedDefaultFolder(outSharedName, 9) '9=olFolderCalendar
    Set OutMeet = outCalendarFolder.Items.Add(1) '1=olAppointmentItem
    
    Dim Recipients As Recipients
    Set Recipients = OutMail.Recipients
    
    Dim objOutlookRecip As Recipient
    Set objOutlookRecip = Recipients.Add(shData.Cells(r, 11).Value)
    
    Dim i As Long
    For i = 1 To OutApp.Session.Accounts.Count
            If OutApp.Session.Accounts.Item(i) = Range("userMail") Then
                Exit For
            End If
    Next i
    
    Dim OutAccount As Outlook.account
    Set OutAccount = OutApp.Session.Accounts.Item(i)
    
    objOutlookRecip.Type = 1
    
    With OutMeet
            Dim sDate As Date
            sDate = Cells(r, 2).Value + Cells(r, 3).Value
            
            Dim eDate As Date
            eDate = Cells(r, 4).Value + Cells(r, 5).Value
            
            Dim rDate As Date
            rDate = Cells(r, 7).Value + Cells(r, 8).Value
            
            Dim minBstart As Long
            minBstart = DateDiff("n", sDate, eDate)
            
            .Subject = Cells(r, 1).Value
            .RequiredAttendees = Cells(r, 11).Value
            .Start = sDate
            .End = eDate
            .Importance = olImportanceHigh
            .ReminderMinutesBeforeStart = minBstart
            .Categories = Cells(r, 9)
            .Body = Cells(r, 10)
            .MeetingStatus = olMeeting
            .SendUsingAccount = OutAccount
            
            'Resolve each Recipient's name.
            For Each objOutlookRecip In OutMeet.Recipients
                objOutlookRecip.Resolve
            Next
            
            .Send
    End With

    Set OutApp = Nothing
    
End Sub