Link to home
Start Free TrialLog in
Avatar of Luis Diaz
Luis DiazFlag for Colombia

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

Open in new window

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


Avatar of dfke
dfke

Hi,

You can try:

Option Explicit

Sub SendInviteToMultiple()
    Dim OutApp As Outlook.Application
    Dim Outmeet As Outlook.AppointmentItem
    Dim setupsht As Worksheet
    Dim attendeeName As String
    Dim attendeeEmail As String
    Dim startTime As Date
    Dim duration As Integer
    Dim importance As Outlook.OlImportance
    Dim bodyMessage As String
    Dim meetingLocation As String
    
    Set setupsht = ThisWorkbook.Worksheets("Setup")
    Set OutApp = New Outlook.Application
    
    For i = 2 To setupsht.Range("A" & setupsht.Rows.Count).End(xlUp).Row
        
        attendeeName = setupsht.Range("A" & i).Value
        attendeeEmail = setupsht.Range("E" & i).Value
        startTime = setupsht.Range("C" & i).Value
        duration = setupsht.Range("D" & i).Value
        importance = olImportanceHigh
        bodyMessage = setupsht.Range("G" & i).Value
        meetingLocation = ""
        If Not IsEmpty(setupsht.Range("H" & i).Value) Then
            meetingLocation = setupsht.Range("H" & i).Value
        End If
        
        Set Outmeet = OutApp.CreateItem(olAppointmentItem)
        
        With Outmeet
            .Subject = "Invitation to an interview"
            .Start = startTime
            .Duration = duration
            .Location = meetingLocation
            .Body = "Hello " & attendeeName & "," & vbLf & vbLf & bodyMessage
            .Importance = importance
            .MeetingStatus = olMeeting
            .ReminderMinutesBeforeStart = 15
            .RequiredAttendees = attendeeEmail
            .OptionalAttendees = ""
            .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
        Set Outmeet = Nothing
        
    Next i
    
    Set OutApp = Nothing
    Set setupsht = Nothing
    
End Sub

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
Avatar of Luis Diaz

ASKER

Hello,

I tested but I have the following:

User generated image

Regards,

Luis.

Hi,

sorry about that.

Replace the following line:

Set OutApp = Outlook.Application

Open in new window


With:

Dim outApp As Object
Set outApp = CreateObject("Outlook.Application")

Open in new window



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

Open in new window


~bp

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:

User generated imageWhy?

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

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

Open in new window

However I am still having the invitation open and I want to send it without having the following popup:

MSTeams auto inviter.xlsm


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…

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

Open in new window

#Const EarlyBinding = False
#If EarlyBinding Then
#Else
#End If

Open in new window






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

Open in new window



but we don't know why are we getting the following error 53:


User generated imageI attach reference file.

MSTeams auto inviter_V4.xlsm


SOLUTION
Avatar of dfke
dfke

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial

Hello,

I have the following error message:

User generated image

User generated image


Hi,

I'll follow up later today.


Cheers

Hi,

Are you able to make a proposal for this?

Thank you for your help.

Regards,

Luis.

ASKER CERTIFIED SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial

Thank you very much for those useful advices!