VBA to add signature in email body

P

Prashant1211

New Member
Joined
Jun 9, 2020
Messages
33
Office Version
  1. 2016
Platform
  1. Windows
Hello VBA experts,

I have below code works perfectly to create email but i am missing the signature. I tried many codes available on internet but nothing worked. can someone help me with this to add signature in the email ?

Thanks for your answers.

below is the code -

Sub SendMail()
Dim OutlookApp As Object
Set OutlookApp = CreateObject("Outlook.Application")
ActiveCell.EntireRow.Select
Dim var As Variant:
var = Selection.Value
Dim outlookMail As Object
Set outlookMail = OutlookApp.CreateItem(0)
With outlookMail
.To = var(1, 6)
.CC = "xyz"
.Subject = "update on - " & var(1, 4) & "_" & var(1, 5)
.body = "Hello " & var(1, 6) & "," & vbNewLine & vbNewLine & "Below is the update for you " & var(1, 27) & vbNewLine & vbNewLine & "Planned on: " & var(1, 40) & vbNewLine & vbNewLine & var(1, 20) & vbNewLine & vbNewLine & "Thanks and best regards"
End With
outlookMail.Display
End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
Hi,

I use the below and it works perfect

VBA Code: 
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"

    '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
Sub Mail_Outlook()
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim strbody1 As String
                                                      
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim rng As Range

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("daily (2)").Range("A1:G" & LastRow)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "<BODY style=font-size:11pt;font-family:Calibri>Hi," & "<BR><BR>" & _
              "See Below For Summary of Reported Staff Who Are Not In Work Today.<br>"
    strbody1 = "Kind Regards</BODY>"

    On Error Resume Next

    With OutMail
        .Display
        .To = "test@test.com" & ";" & "Test1@Test.com"
        .CC = ""
        .BCC = ""
        .Subject = "Daily Manning - " & Sheets("daily (2)").Range("A1")
        .htmlbody = strbody & "<br>" & RangetoHTML(rng) & "<BR><BR>" & strbody1 & .htmlbody
        .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Sheets("Daily (2)").Delete
    End Sub
 
Upvote 0
leighmetcalfe said:
this sends a section on an excel sheet and pastes it's to an email
Click to expand...
Thanks, In my case i use the active row data in the email. I have no idea how to implement above code in the one i use. Can you help in adjusting my code ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Solved
Email Body
Replies
9
Views
378
Trixterz
T
S
  • Solved
Fix Macro, open outlook instead of direct email send
Replies
1
Views
454
Sergio
S
J
  • Question
VBA code to send an email if a certain IF Criteria is met that loops when the spreadsheet is open
Replies
1
Views
234
joeyc123
J
C
  • Solved
Adding an editable pop-up
Replies
3
Views
275
ChaosPup
C
The Ruff Report
  • Question
Help adjusting Macro to email multiple cc addresses
Replies
1
Views
375
The Ruff Report
The Ruff Report

Forum statistics

Threads
1,214,819
Messages
6,121,739
Members
449,050
Latest member
excelknuckles

Share this page

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