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

[Alphaboss7]

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.

 

[Logit]

.

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

	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​	L​	M​	N​
1​	Names					To	CC		Attachments	Subject	Msg Body
2​	A2					me@yahoo			""	Bye	I'm leaving
3​	A3					You@yahoo			""	Hello	Nice to meet you
4​	A4					him@yahoo			""	What ?	Please repeat
5​
6​
7​

 

[Alphaboss7]

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

 

[Logit]

.

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

	A​	B​	C​	D​	E​	F​	G​	H​
1​		Email Address	Subject	Email in CC	UserName​	Password​
2​	Mary	test@test.com	Fill your time sheet	test@testcc.com	xtz​	123​
3​	Tom	test1@test.com	Fill your time sheet	test1@testcc.com	123​	xyz​
4​	Carl	test2@test.com	Fill your time sheet	test2@testcc.com	tdk​	cal​
5​					​	​
6​	Sally	test4@test.com	Fill your time sheet	test4@testcc.com	546​	857​
7​					​	​
8​	Liz	test6@test.com	Fill your time sheet	test6@testcc.com	ghj​	kmj​

 

[Alphaboss7]

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?

 

[Logit]

.

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

 

[Alphaboss7]

Thanks Logit, that works!

 

[Logit]

.
You are welcome