Send Outlook Meeting Invitation using Excel - excel

Question

I am looking to send meeting invitations for each row in a worksheet.
I am able to create an item that when displayed shows as an appointment, not a meeting request that can be sent to others. I need to click on "Invite Attendees" in Outlook and then the email addresses display and I can send but it would take a lot of time if I have more than a few rows.
This seems to be a common problem as I found this question in other forums but none have a solution that worked for me.
Sub SendAction()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For Each cell In Worksheets("Action Log").Range("H5:H50").Cells
Set OutMail = OutApp.CreateItem(1)
If cell.Value Like "*#*" Then 'try with less conditions first
With OutMail
.MeetingStatus = olMeeting
.RequiredAttendees = Cells(cell.Row, "H").Value
.Subject = Cells(cell.Row, "I").Value
.Body = Cells(cell.Row, "I").Value
.Start = Cells(cell.Row, "E").Value & " " & TimeValue("8:00 AM")
.Location = "Your Office"
.Duration = 15 ' 15 minute meeting
.BusyStatus = 0 ' set as free
.ReminderSet = True 'reminder set
.ReminderMinutesBeforeStart = "20160" 'reminder 2 weeks before
.display
End With
Cells(cell.Row, "K").Value = "sent"
Set OutMail = Nothing
End If
Next cell
Application.ScreenUpdating = True
End Sub
Here is one alternative I tried but it did not fix the issue:
Application.Wait DateAdd("s", 2, Now) 'waiting for 2 sec to let OL window to display.
SendKeys "%s", True 'Sending Mail.
Set olApt = Nothing
MsgBox "Invite Sent", vbInformation
Source: https://excel-buzz.blogspot.com/2015/03/automation-sending-invitation-to.html
Another alternative is to change .Display to .Save but the .Send function won't work either way and I would then need to open the meeting request from my draft messages in Outlook.

Answer 1

Try this?
Sub SendAction()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For Each cell In Worksheets("Action Log").Range("H5:H50").Cells
Set OutMail = OutApp.CreateItem(1)
If cell.Value Like "*#*" Then 'try with less conditions first
With OutMail
.MeetingStatus = olMeeting
.RequiredAttendees = Cells(cell.Row, "H").Value
.RequiredAttendees.Type = olRequired
.Subject = Cells(cell.Row, "I").Value
.Body = Cells(cell.Row, "I").Value
.Start = Cells(cell.Row, "E").Value & " " & TimeValue("8:00 AM")
.Location = "Your Office"
.Duration = 15 ' 15 minute meeting
.BusyStatus = 0 ' set as free
.ReminderSet = True 'reminder set
.ReminderMinutesBeforeStart = "20160" 'reminder 2 weeks before
.display
.send
End With
Cells(cell.Row, "K").Value = "sent"
Set OutMail = Nothing
End If
Next cell
Application.ScreenUpdating = True
End Sub

Answer 2

I realized the issue. The cell I was linking to for the emails contained a formula instead of the email address text. Once I changed the email addresses to text instead of a formula my VBA worked perfectly.

Answer 3

I had the same problem as the OP but rather than resort to send keys I used the inspector to access the Invite Attendees ribbon command. Here are excerpts from the code:
Dim oApp As Object
Dim OutMail As Object
Dim oCommandBar As Object 'Office.CommandBars
Dim oInsp As Object 'Outlook.inspector
Set outMail = oApp.CreateItem(1)
'then these in the loop to get access to the ribbon:
Set oInsp = OutMail.GetInspector
Set oCommandBar = oInsp.CommandBars
'Show the mail item
outMail.display
'Press the Invite attendees ribbon item
oCommandBar.ExecuteMso ("InviteAttendees")