asked on
Excel VBA: send automatically outlook/teams invitation based on a Excel sheet
Hello experts,
I found the following code:
Option Explicit
Sub SendInviteToMultiple()
Dim OutApp As Outlook.Application, Outmeet As Outlook.AppointmentItem
Dim I As Long, setupsht As Worksheet
Set setupsht = Worksheets("Setup")
For I = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set OutApp = Outlook.Application
Set Outmeet = OutApp.CreateItem(olAppointmentItem)
With Outmeet
.Subject = "Invitation to an interview"
.RequiredAttendees = setupsht.Range("E" & I).Value
.OptionalAttendees = setupsht.Range("F" & I).Value
.Start = setupsht.Range("C" & I).Value
.Duration = setupsht.Range("D" & I).Value
.Importance = olImportanceHigh
.Body = "Hello " & setupsht.Range("A" & I).Value & "," & vbLf & vbLf & _
"You are invited for an interview as scheduled above" & vbLf & "Regards,Admin"
.Location = "Microsoft teams"
.MeetingStatus = olMeeting
.ReminderMinutesBeforeStart = 15
.Display
'Add teams meeting to invite
SendKeys "%H", True 'pressing ALT+H
SendKeys "TM", True 'Pressing "TM"
'Application.Wait (Now + TimeValue("00:00:01"))
SendKeys "^~" 'Press CTRL+ENTER ^ means CTRL, ~ means ENTER
'.Send
End With
Next I
Set OutApp = Nothing
Set Outmeet = Nothing
End Sub
In order to send automatically Teams invitation through Outlook.
I would like to cuztomize the Body and if possible to add a new column to specify the location in which is the body text to be sent instead of having a unique body message in hard code.
I attach reference file.
Regards,
Luis.Send-outlook-invitations.xlsm
sorry about that.
Replace the following line:
Set OutApp = Outlook.Application
With:
Dim outApp As Object
Set outApp = CreateObject("Outlook.Application")
Cheers
Luis,
With regard to the error you posted a screen capture of, you need to add the following definition for the variable "i" in that procedure:
Dim i As Long
ASKER
Thank you very much for those advice:
The macro is debugged however I expect to send the invitation automatically instead of have the Windows Outlook Popup to click on send. I am talking about this one:
Because If I want to report 50 invitations it would be time consuming to click on "Send" 50 times.
Thank you for your help.
Have you tried changing the commented .Send line to not be commented out? That should automatically send the email…
~bp
ASKER
Hello,
I found another way to do it like this:
Sub SetApptWithHTMLContent()
'Code patched together by Ashok Karkera
'SetapptwithHTMLContent base code by Tim Williams in https://stackoverflow.com/questions/52300231/how-to-include-formatted-text-in-the-body-of-an-outlook-invite-from-excel
Dim olapp As Outlook.Application, appt As Outlook.AppointmentItem
Dim m As Outlook.MailItem
Dim rtf() As Byte
Dim ml1 As Worksheet
Dim supermessage As String
Dim r As Long
Dim sh As Worksheet
Set sh = Sheets("Scheduler")
Dim startline As String
'Copy HTML Message (Code reference Ron-De Bruin)
Set ml1 = ActiveWorkbook.Sheets("Message")
supermessage = ml1.Range("B4").Value
r = 2
Do
Set olapp = New Outlook.Application
Set m = olapp.CreateItem(olMailItem)
Set appt = olapp.CreateItem(olAppointmentItem)
appt.Subject = sh.Cells(r, 4).Value & " — " & sh.Cells(r, 2).Value
appt.Recipients.Add sh.Cells(r, 10).Value
appt.OptionalAttendees = sh.Cells(r, 12).Value
appt.Start = sh.Cells(r, 7).Value + sh.Cells(r, 6).Value
appt.End = sh.Cells(r, 9).Value + sh.Cells(r, 8).Value
appt.Location = sh.Cells(r, 1).Value
'...set other appointment properties
appt.Display
'put the HTML into the mail item, then copy and paste to appt
m.BodyFormat = olFormatHTML
m.HTMLBody = startline & supermessage
m.GetInspector().WordEditor.Range.FormattedText.Copy
appt.GetInspector().WordEditor.Range.FormattedText.Paste
'Send Keys to convert Calendar invite to MS Teams invite
SendKeys "%h"
SendKeys "t"
SendKeys "m"
m.Close False 'don't save...
r = r + 1
startline = ""
Loop While Len(sh.Cells(r, 10).Value) > 5
End Sub
However I am still having the invitation open and I want to send it without having the following popup:
If someone can help me:
>To debug the file, I don't know why I am not able to report information in Column A
>Be able to properly modify the html in the other sheet
>Implement a Flag that will allows me to Send by each row with popup or directly without popup
Thank you for your help.
My feeling is that since you need to send keystrokes to Outlook to make the Teams invite, you are going to have to see the pop up. But maybe someone else has a way around it…
ASKER
Indeed and FYI I use the following code which works perfectly when it comes send e-mails.
So it should be an option to align with this and make it work with meetings, I think :-).
Option Explicit
#Const EarlyBinding = False
' Global variables
#If EarlyBinding Then
Dim FSO As Scripting.FileSystemObject
#Else
Dim FSO As Object
#End If
Sub SendMails()
' Local variables
Dim wsConfig As Worksheet
Dim rw As Integer
Dim Ans As VbMsgBoxResult
Dim sentCount As Long
Dim strBodyTemplate As String
' Get confirmation to proceed
Ans = MsgBox("Please make sure that following information is reported as of row 2" & vbNewLine & vbNewLine & _
"1-Column A: Email receipent " & vbNewLine & _
"2-Column B: Email cc " & vbNewLine & _
"3-Column C: Attach file" & vbNewLine & _
"4-Column D: Recipient name" & vbNewLine & vbNewLine & _
"Click on OK if all good and click on Cancel to exit", vbOKCancel, "Confirm Before You Proceed!")
If Ans = vbCancel Then
MsgBox "You cancelled sending emails.", vbInformation, "Action Cancelled!"
Exit Sub
End If
' Initialization
Set FSO = CreateObject("Scripting.FileSystemObject")
Set wsConfig = ActiveSheet
' Try to find and load body template (HTML)
strBodyTemplate = BodyTemplate
If strBodyTemplate = "" Then
Exit Sub
End If
' Loop over sheet contents sending emails
sentCount = 0
For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
sentCount = sentCount + 1
SendMail wsConfig.Cells(rw, 1).Value, _
wsConfig.Cells(rw, 2).Value, _
"This is a test message", _
wsConfig.Cells(rw, 3).Value, _
BuildBody(wsConfig.Cells(rw, 4).Value, strBodyTemplate)
Next rw
' Cleanup
Set FSO = Nothing
MsgBox "Completed sending " & sentCount & " emails.", vbInformation, "Send Complete"
End Sub
Function BuildBody(strName As String, strBody As String) As String
' Stuff in any varuable values
BuildBody = Replace(strBody, "[[NAME]]", strName)
' BuildBody = Replace(BuildBody, "[[XXXXX]]", strName)
' BuildBody = Replace(BuildBody, "[[YYYYY]]", strName)
End Function
Function BodyTemplate() As String
' Local Variables
Const ForReading = 1
Const TristateUseDefault = -2
Dim strTemplatePath As String
' Locate HTML template file for emails (same name as workbook, with HTML extension)
strTemplatePath = Replace(Application.ActiveWorkbook.FullName, ".xlsm", ".html", 1, -1, vbTextCompare)
If FSO.FileExists(strTemplatePath) Then
' Read entire file into variable
With FSO.OpenTextFile(strTemplatePath, ForReading, False, TristateUseDefault)
BodyTemplate = .ReadAll
.Close
End With
Else
BodyTemplate = ""
MsgBox "Missing message template file """ & strTemplatePath & """.", vbCritical, "Template file error"
End If
End Function
' *************************************************************************
' Author:
' Creation date: 2020/04/16 08:39:26
' Description: Function to send e-mails
' ***************************************************************************
Sub SendMail(strTo As String, strCC As String, strSubject, strAttachment As String, strBody As String)
' Local variables
Dim strAttachmentPath As String
On Error GoTo ErrHandler
' Resolve any relative file references to a fully qualified path
strAttachmentPath = FSO.GetAbsolutePathName(strAttachment)
' Set Outlook Application object (early binding)
#If EarlyBinding Then
Dim objOutlook As Outlook.Application
#Else
Dim objOutlook As Object
#End If
Set objOutlook = CreateObject("Outlook.Application")
' Set Email object (early binding)
#If EarlyBinding Then
Dim objEmail As Outlook.MailItem
#Else
Dim objEmail As Object
Const olMailItem = 0
#End If
Set objEmail = objOutlook.CreateItem(olMailItem)
' Add information to email and send
With objEmail
.To = strTo
.CC = strCC
If FSO.FileExists(strAttachmentPath) Then
.Attachments.Add (strAttachmentPath)
End If
.Subject = strSubject
.HTMLBody = strBody
.Display ' ********** DISPLAY MESSAGE **********
.Send
End With
' Clean-up and exit
Set objEmail = Nothing
Set objOutlook = Nothing
Exit Sub
ErrHandler:
' Display error information and exit sub
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: SendMail" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl), _
vbOKOnly + vbCritical, _
"An Error has Occured!"
End Sub
#Const EarlyBinding = False
#If EarlyBinding Then
#Else
#End If
ASKER
Hello experts,
I review the procedure with a friend
Sub SetApptWithHTMLContent()
Dim olapp As Outlook.Application, appt As Outlook.AppointmentItem
Dim m As Outlook.MailItem
Dim rtf() As Byte
Dim ml1 As Worksheet
Dim supermessage As String
Dim r As Long
Dim sh As Worksheet
Dim type_meet As String 'Variable to show the message
Dim close_outlook As Boolean 'Close outlook if it is closed
Dim continue As Boolean 'Continue with the sent process.
Set sh = Sheets("Scheduler")
'Copy HTML Message (Code reference Ron-De Bruin)
Set ml1 = ActiveWorkbook.Sheets("Message")
supermessage = ml1.Range("B4").Value
r = 2
'If outlook is closed let the user know
On Error GoTo 53
continue = True
Do
'Validate or not the e-mail.
If sh.Range("K" & r).Value <> "" Then
If sh.Range("L" & r).Value <> "No" Then
r = r + 1
continue = False
Else
continue = True
End If
Else
continue = True
End If
If continue = True Then
Set olapp = New Outlook.Application
Set m = olapp.CreateItem(olMailItem)
Set appt = olapp.CreateItem(olAppointmentItem)
appt.MeetingStatus = olMeeting 'Teams meeting
appt.Subject = sh.Cells(r, 2).Value
appt.Recipients.Add sh.Cells(r, 7).Value
appt.OptionalAttendees = sh.Cells(r, 9).Value
appt.Start = sh.Cells(r, 3).Value + sh.Cells(r, 4).Value
appt.End = sh.Cells(r, 5).Value + sh.Cells(r, 6).Value
appt.Location = sh.Cells(r, 1).Value
'put the HTML into the mail item, then copy and paste to appt
m.BodyFormat = olFormatHTML
m.HTMLBody = supermessage
m.GetInspector().WordEditor.Range.FormattedText.Copy
appt.GetInspector().WordEditor.Range.FormattedText.Paste
m.Close False 'don't save...
'Send the message
type_meet = sh.Range("J" & r).Value
If type_meet = "Send" Then
appt.Send
ElseIf type_meet = "Display" Then
appt.Display
Else
appt.Display
End If
sh.Range("K" & r).Value = "Send - " & Format(Now(), "dd/mm/yyyy HH:MM:SS")
r = r + 1
End If
Loop While Len(sh.Cells(r, 2).Value) > 5
MsgBox "Invitations sent successfully", vbInformation, "Important"
Exit Sub
53:
MsgBox "Outlook is closed, please open the application to send the invitations", vbExclamation, "Important"
End Sub
but we don't know why are we getting the following error 53:
I'll follow up later today.
Cheers
ASKER
Hi,
Are you able to make a proposal for this?
Thank you for your help.
Regards,
Luis.
ASKER
Thank you very much for those useful advices!
You can try:
Open in new window
The message body is now sourced from the "G" column of the Excel sheet, and an optional "H" column can be used to specify the meeting location.
Cheers