Email using VBA but changing a few words in Body depending on Recipient

Alphaboss7

New Member
Joined
Jul 31, 2017
Messages
28
Hello,

I need to send out a standardized email, but I need to change a few fields within the body of the email to reflect names specific to the recipient. It's pretty simple, but I can't find anything specific to this case.

Example:

Hello _______,

Here are your login credentials:

Username: _________
Password: ________

Thank you.
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
.
Code:
Option Explicit


Sub CreateMail()
    Dim objOutlook      As Object
    Dim objMail         As Object
    Dim i               As Integer
    Const olMailItem    As Long = 0
                                    
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row '~~> Change to i = 2 if you have headings
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(olMailItem)
                                        
        With objMail '~~> Chnage Below columns to suit your data, this was based off your example offsets
            .To = Range("F" & i).Value
            .cc = Range("G" & i).Value
            .Subject = Range("J" & i).Value
            '.Attachments.Add Range("I" & i).Value
            .HTMLBody = RangetoHTML(Range("K" & i)) '~~> You can change this to any range
            .display
        End With
                                        
        Set objOutlook = Nothing
        Set objMail = Nothing
    Next i
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"


    'Copy the range and create a new workbook to past the data in
    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


    'Publish the sheet to a htm file
    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


    'Read all data from the htm file into RangetoHTML
    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=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function



[Table="width:, class:head"][tr=bgcolor:#888888][th] [/th][th]
A
[/th][th]
B
[/th][th]
C
[/th][th]
D
[/th][th]
E
[/th][th]
F
[/th][th]
G
[/th][th]
H
[/th][th]
I
[/th][th]
J
[/th][th]
K
[/th][th]
L
[/th][th]
M
[/th][th]
N
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
1
[/td][td]Names[/td][td][/td][td][/td][td][/td][td][/td][td]To[/td][td]CC[/td][td][/td][td]Attachments[/td][td]Subject[/td][td]Msg Body[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
2
[/td][td]A2[/td][td][/td][td][/td][td][/td][td][/td][td]me@yahoo[/td][td][/td][td][/td][td]""[/td][td]Bye[/td][td]I'm leaving[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
3
[/td][td]A3[/td][td][/td][td][/td][td][/td][td][/td][td]You@yahoo[/td][td][/td][td][/td][td]""[/td][td]Hello[/td][td]Nice to meet you[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
4
[/td][td]A4[/td][td][/td][td][/td][td][/td][td][/td][td]him@yahoo[/td][td][/td][td][/td][td]""[/td][td]What ?[/td][td]Please repeat[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
5
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
6
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
7
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]
[/table]
 
Last edited:
Upvote 0
This is great, but the msg body will be the same for all recipients, so the names need to change with the same message. And I would like to make sure the body of the email isn't stretched out to the right, as in, it would be nice to have multiple lines.

Example:

Hello, __Name__

Here are your user credentials:

Username: __Username Field__
Password: __Password Field__

Let me schedule a training for you.
Do you have time this week?

Let me know at your earliest convenience.

Thanks,
Signature
 
Upvote 0
.
Code:
Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String
    Dim subject_ As String
    Dim body_ As String


     'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")


     'Loop through the rows
    For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)


        email_ = cell.Offset(0, 1).Value
        subject_ = cell.Offset(0, 2).Value
        body_ = "Hello " & cell.Value & " :" & vbCrLf & vbCrLf & _
        "Here are your user credentials: " & vbCrLf & vbCrLf & _
        "Username: " & cell.Offset(0, 4).Value & vbCrLf & _
        "Password: " & cell.Offset(0, 5).Value & vbCrLf & vbCrLf & _
        "Let me schedule a training for you." & vbCrLf & _
        "Do you have time this week? " & vbCrLf & vbCrLf & _
        "Let me know at your earliest convenience. " & vbCrLf & vbCrLf & _
        "Thanks," & vbCrLf & _
        "Place Your Signature Here "
        
        cc_ = cell.Offset(0, 3).Value


        'Create Mail Item and send it
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_
            .CC = cc_
            .Subject = subject_
            .Body = body_
            .Display
        End With
    Next
End Sub



[Table="width:, class:head"][tr=bgcolor:#888888][th] [/th][th]
A
[/th][th]
B
[/th][th]
C
[/th][th]
D
[/th][th]
E
[/th][th]
F
[/th][th]
G
[/th][th]
H
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
1
[/td][td=bgcolor:#548135][/td][td=bgcolor:#548135]Email Address[/td][td=bgcolor:#548135]Subject[/td][td=bgcolor:#548135]Email in CC[/td][td=bgcolor:#548135]
UserName
[/td][td=bgcolor:#548135]
Password
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
2
[/td][td]Mary[/td][td]test@test.com[/td][td]Fill your time sheet[/td][td]test@testcc.com[/td][td]
xtz​
[/td][td]
123​
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
3
[/td][td]Tom[/td][td]test1@test.com[/td][td]Fill your time sheet[/td][td]test1@testcc.com[/td][td]
123​
[/td][td]
xyz​
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
4
[/td][td]Carl[/td][td]test2@test.com[/td][td]Fill your time sheet[/td][td]test2@testcc.com[/td][td]
tdk​
[/td][td]
cal​
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
5
[/td][td][/td][td][/td][td][/td][td][/td][td]
[/td][td]
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
6
[/td][td]Sally[/td][td]test4@test.com[/td][td]Fill your time sheet[/td][td]test4@testcc.com[/td][td]
546​
[/td][td]
857​
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
7
[/td][td][/td][td][/td][td][/td][td][/td][td]
[/td][td]
[/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
8
[/td][td]Liz[/td][td]test6@test.com[/td][td]Fill your time sheet[/td][td]test6@testcc.com[/td][td]
ghj​
[/td][td]
kmj​
[/td][td][/td][td][/td][/tr]
[/table]
 
Upvote 0
Awesome, Thank you Logit. Now, do you know how to send a hyperlinked website in the body of the email?

And do you know how to include the outlook signature at the bottom?
 
Upvote 0
.
Code:
Option Explicit


Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String
    Dim subject_ As String
    Dim body_ As String
    Dim Signature As String
    
    'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")
    
    '*************************************************************
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else:
        Signature = ""
    End If
    
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
    
    '**************************************************************
    


     'Loop through the rows
    For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)




        email_ = cell.Offset(0, 1).Value
        subject_ = cell.Offset(0, 2).Value
        body_ = "Hello " & cell.Value & " : <br></br> <br></br>" & _
        "Here are your user credentials:  <br></br> <br></br>" & _
        "Username: " & cell.Offset(0, 4).Value & "<br></br>" & _
        "Password: " & cell.Offset(0, 5).Value & "<br></br> <br></br>" & _
        "Let me schedule a training for you. <br></br>" & _
        "Do you have time this week? <br></br> <br></br>" & _
        "Let me know at your earliest convenience. <br></br> <br></br>" & _
        "Thanks,<br></br>" & _
        "Place Your Signature Here <br></br> <br></br>" & _
        "<a href=http://www.formatcells.com> formatcells.com.</a> <br></br> <br></br>" & _
        Signature
        
        cc_ = cell.Offset(0, 3).Value


        'Create Mail Item and send it
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_
            .CC = cc_
            .Subject = subject_
            .HTMLBody = body_
            .Display
        End With
    Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,243
Messages
6,170,967
Members
452,371
Latest member
Frana

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