excelvbaoutlookappointment

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