Excel VBA Macro to send one email to a recipient listed multiple times along with excel table snapshot and attachments

AndreMateus

New Member
Joined
Mar 31, 2023
Messages
11
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Currently, I have a macro that sends a snapshot of a filtered table and pasts it in the body of an outlook email as text and sends it off to the email address listed in a certain cell along with a message in the body of the email. The outlook mailbox defaults to the primary mailbox and I need to be able to select which mailbox to send the email with.

Now, my spreadsheet contains multiple recipients and, often times a recipient may be listed more than once. For this reason, I would like to have only 1 email sent to the recipient even if their email shows multiple times on the table. Along with the snapshot of the table, I would like to add attachments. The number of attachments being sent to the recipient will vary depending on the number of times our recipient shows on the list.

The goal is to distribute soft token files to each requestor but each email must contain the appropriate information for each of our requestors.

Here's a brief summary of what I am looking for:
1 - Need to be able to choose with mailbox the email will be sent from
2 - Email must be sent to 1 recipient even if the same email is showing multiple times (see "Requestor" field).
3 - Email subject line is always the same one
4 - Email Body message is always the same expect it captures/filters the info that should only be sent to our recipient
5 - Must attach one or more files (depending on the number of files being sent to the same submitter). Only 1 file per row. (see "Soft token file name" and "requestor" field).
6 - Not sure if it is possible to have the script loop through the table and complete the above steps but automatically. If not, I would not mind filtering the requests manually and having the emails sent automatically.

Please see pictures below for more information on how my current table looks and how I would like the final email(s) to look like.


Current script:

Sub Soft_Token_Distribution()
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim path As String
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)


With newEmail

.To = Sheet4.Range("L2").Text
.CC = ""
.BCC = ""
.Subject = "SOW Contingent Worker - Remote Access Request"
.Body = "Hi, As part of your Create, Modify or Terminate SOW Contingent Worker ServiceNow request for the below user, you requested Remote Access for the user. Vendor Remote Access has been provisioned for this user. Please share the attached documents with the user so that they can configure their Vendor Remote Access.

regards,
My Signature"


.display
Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor
Sheet4.Range("Table2[#All]").Copy
pageEditor.Application.Selection.Start = Len(.Body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
.display
'.Send
Set pageEditor = Nothing
Set xInspect = Nothing
End With
Set newEmail = Nothing
Set outlook = Nothing
End Sub
 

Attachments

  • Current table.JPG
    Current table.JPG
    208.8 KB · Views: 80
  • Final email results.JPG
    Final email results.JPG
    113.1 KB · Views: 82

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
What is the full path to the folder where the Soft token file names are saved?
 
Upvote 0
Hi,

The full path is:
C:\RemoteAMBA\bin\SoftTokens\

Thank you.

Hi,

The full path is:
C:\RemoteAMBA\bin\SoftTokens\

Thank you.
Also, I've been looking at some videos/tutorials online and managed to have something close to what I am looking for (see code below). The problem appears to be with line 23 (.attachments.Add "C:\RemoteAMBA\bin\SoftTokens\" & Range("g2").Value) as I would like it to grab the attachments for the soft tokens that have to be sent to the appropriate requestor.



Sub Soft_Token_Distribution()
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim path As String


Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)


With newEmail

.To = Sheet4.Range("L2").Text
.CC = ""
.BCC = ""
.Subject = "SOW Contingent Worker - Remote Access Request"
.htmlBody = "Hi, <br/><br/> As part of your <b> Create, Modify or Terminate SOW Contingent Worker </b> ServiceNow request for the below user, you requested Remote Access for the user. <br/><br/> Vendor Remote Access has been provisioned for this user. Please share the attached documents with the user so that they can configure their Vendor Remote Access. <br/><br/> Regards,"

.attachments.Add "Enter Full path here for fixed attachment #1"
.attachments.Add "Enter Full path here for fixed attachment #2"
.attachments.Add "C:\RemoteAMBA\bin\SoftTokens\" & Range("g2").Value ' THE IDEA HERE IS TO HAVE THE CODE READ THE PATH DISPLAYED FOR EACH FILTERED COLUMN WHERE WE ARE FILTERING BASED ON EMAIL

Set .SendUsingAccount = outlook.Session.Accounts.Item(2)

.display
Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor


Sheet4.Range("Table2[#All]").Copy

'pageEditor.Application.Selection.Start = Len(.Body)
pageEditor.Application.Selection.Start = 316
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

.display
'.Send
Set pageEditor = Nothing
Set xInspect = Nothing
End With
Set newEmail = Nothing
Set outlook = Nothing
End Sub
 
Upvote 0
Untested. Change the signature name (in red) to the name you gave to your signature when you created it. Change the sheet names (in blue) to suit your needs.
Rich (BB code):
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, SigString As String, sPath As String, fName As Range
    sPath = "C:\RemoteAMBA\bin\SoftTokens\"
    SigString = Environ("appdata") & "\Microsoft\Signatures\SignatureName.htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    v = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)).Resize(, 12.Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 11)) Then
                .Add v(i, 11), Nothing
                With Sheets("Sheet1")
                    .Range("A1").CurrentRegion.AutoFilter 11, v(i, 11)
                    Set rng = .AutoFilter.Range
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 12)
                        .Subject = "SOW Contingent Worker - Remote Access Request"
                        .HTMLBody = "Hi, As part of your Create, Modify or Terminate SOW Contingent Worker ServiceNowm requestfor the below user, you requested Remote Access for the user. Vendor Remote Access has been provisioned for this user. Please share the attached documents with the user so that they can configure their Vendor Remote Access." _
                        & "<br><br>" & RangetoHTML(rng) & "<br><br>" & "Regards," & "<br>" & Signature
                        For Each fName In Sheets("Sheet1").Range("G2", Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                            .attachments.Add sPath & fName
                        Next fName
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    Sheets("Sheet1").Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
 
Upvote 0
Untested. Change the signature name (in red) to the name you gave to your signature when you created it. Change the sheet names (in blue) to suit your needs.
Rich (BB code):
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, SigString As String, sPath As String, fName As Range
    sPath = "C:\RemoteAMBA\bin\SoftTokens\"
    SigString = Environ("appdata") & "\Microsoft\Signatures\SignatureName.htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    v = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)).Resize(, 12.Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 11)) Then
                .Add v(i, 11), Nothing
                With Sheets("Sheet1")
                    .Range("A1").CurrentRegion.AutoFilter 11, v(i, 11)
                    Set rng = .AutoFilter.Range
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 12)
                        .Subject = "SOW Contingent Worker - Remote Access Request"
                        .HTMLBody = "Hi, As part of your Create, Modify or Terminate SOW Contingent Worker ServiceNowm requestfor the below user, you requested Remote Access for the user. Vendor Remote Access has been provisioned for this user. Please share the attached documents with the user so that they can configure their Vendor Remote Access." _
                        & "<br><br>" & RangetoHTML(rng) & "<br><br>" & "Regards," & "<br>" & Signature
                        For Each fName In Sheets("Sheet1").Range("G2", Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                            .attachments.Add sPath & fName
                        Next fName
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    Sheets("Sheet1").Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
Tried the above. I was getting an error on this line - v = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)).Resize(, 12.Value
After changed the line to v = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)).Resize(, 12).Value, the excel file stopped working and now I am unable to open it :(

1680371252394.png
 
Upvote 0
Untested. Change the signature name (in red) to the name you gave to your signature when you created it. Change the sheet names (in blue) to suit your needs.
Rich (BB code):
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, SigString As String, sPath As String, fName As Range
    sPath = "C:\RemoteAMBA\bin\SoftTokens\"
    SigString = Environ("appdata") & "\Microsoft\Signatures\SignatureName.htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    v = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)).Resize(, 12.Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 11)) Then
                .Add v(i, 11), Nothing
                With Sheets("Sheet1")
                    .Range("A1").CurrentRegion.AutoFilter 11, v(i, 11)
                    Set rng = .AutoFilter.Range
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 12)
                        .Subject = "SOW Contingent Worker - Remote Access Request"
                        .HTMLBody = "Hi, As part of your Create, Modify or Terminate SOW Contingent Worker ServiceNowm requestfor the below user, you requested Remote Access for the user. Vendor Remote Access has been provisioned for this user. Please share the attached documents with the user so that they can configure their Vendor Remote Access." _
                        & "<br><br>" & RangetoHTML(rng) & "<br><br>" & "Regards," & "<br>" & Signature
                        For Each fName In Sheets("Sheet1").Range("G2", Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                            .attachments.Add sPath & fName
                        Next fName
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    Sheets("Sheet1").Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
File is now working but getting error here:

1680371561706.png
 
Upvote 0
It would be easier to help if you could use the XL2BB to BB app (click the icon in the top menu to attach a screenshot, not a picture, of your sheet. Alternately, you could upload a copy of your file to a free site such as drop.com or box.com. Mark the file for sharing, and you will be given a link to the file that you can post here. Desensitize the file if necessary.
 
Upvote 0
It would be easier to help if you could use the XL2BB to BB app (click the icon in the top menu to attach a screenshot, not a picture, of your sheet. Alternately, you could upload a copy of your file to a free site such as drop.com or box.com. Mark the file for sharing, and you will be given a link to the file that you can post here. Desensitize the file if necessary.
Hope this is what you are looking for:

Book1.xlsm
ABCDEFGHIJKL
1RITM NumberOpenedWorker First NameWorker Last NameContract Start DateIDSoft Token File NameCost CenterDomainRemote AccessRequestorEmail
2RITM #13/29/2023First_Name_1Last_Name_112-04-23ID_1ID_1_000123456789.sdtid3638TDBFGYesAndre MateusAndre.Mateus@test.com
3RITM #23/29/2023First_Name_2Last_Name_203-04-23ID_2ID_2_000123456789.sdtid7983TDBFGYesAndre MateusAndre.Mateus@test.com
4RITM #33/27/2023First_Name_3Last_Name_324-03-23ID_3ID_3_000123456789.sdtid9947TDBFGYesAndre MateusAndre.Mateus@test.com
5RITM #43/29/2023First_Name_4Last_Name_411-04-23ID_4ID_4_000123456789.sdtid6084TDBFGYesAndre MateusAndre.Mateus@test.com
6RITM #53/29/2023First_Name_5Last_Name_503-04-23ID_5ID_5_000123456789.sdtid3510TDBFGYesJohn DoeJohn.Doe@test.com
7RITM #63/29/2023First_Name_6Last_Name_613-04-23ID_6ID_6_000123456789.sdtid3930TDBFGYesJohn DoeJohn.Doe@test.com
8RITM #73/29/2023First_Name_7Last_Name_702-02-23ID_7ID_7_000123456789.sdtid9754TDBFGYesJohn DoeJohn.Doe@test.com
9RITM #83/27/2023First_Name_8Last_Name_824-03-23ID_8ID_8_000123456789.sdtid9120TDBFGYesJohn DoeJohn.Doe@test.com
10RITM #93/29/2023First_Name_9Last_Name_906-04-23ID_9ID_9_000123456789.sdtid3638TDBFGYesMr CleanMr.Clean@test.com
11RITM #103/29/2023First_Name_10Last_Name_1015-04-23ID_10ID_10_000123456789.sdtid7983TDBFGYesMr CleanMr.Clean@test.com
12RITM #113/27/2023First_Name_11Last_Name_1125-03-23ID_11ID_11_000123456789.sdtid9947TDBFGYesMr CleanMr.Clean@test.com
13RITM #123/29/2023First_Name_12Last_Name_1211-04-23ID_12ID_12_000123456789.sdtid6084TDBFGYesMr CleanMr.Clean@test.com
14RITM #133/29/2023First_Name_13Last_Name_1303-04-23ID_13ID_13_000123456789.sdtid3510TDBFGYesSamuel JacksonSamuel.Jackson@test.com
15RITM #143/29/2023First_Name_14Last_Name_1413-04-23ID_14ID_14_000123456789.sdtid3930TDBFGYesPeter PanPeter.Pan@test.com
16RITM #153/29/2023First_Name_15Last_Name_1503-02-23ID_15ID_15_000123456789.sdtid9754TDBFGYesPeter PanPeter.Pan@test.com
17RITM #163/27/2023First_Name_16Last_Name_1625-03-23ID_16ID_16_000123456789.sdtid9120TDBFGYesPeter PanPeter.Pan@test.com
18RITM #173/29/2023First_Name_17Last_Name_1724-04-23ID_17ID_17_000123456789.sdtid3638TDBFGYesRobin WoodRobin.Wood@test.com
19RITM #183/29/2023First_Name_18Last_Name_1825-03-23ID_18ID_18_000123456789.sdtid7983TDBFGYesAngus MacGyverAngus.MacGyver@test.com
20RITM #193/27/2023First_Name_19Last_Name_1926-03-23ID_19ID_19_000123456789.sdtid9947TDBFGYesAngus MacGyverAngus.MacGyver@test.com
Token Distribution
 
Upvote 0
I may have accidentlly left out a bracket. Replace this line of code:
Code:
v = Sheets("Sheet4").Range("A2", Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp)).Resize(, 12.Value
with this one;
Rich (BB code):
v = Sheets("Sheet4").Range("A2", Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp)).Resize(, 12).Value
 
Upvote 0

Forum statistics

Threads
1,224,813
Messages
6,181,118
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top