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
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