Default signature at the end of email

You can set your signature IN Outlook, you dont need VBA for that

You can set your default signature in your gmail account.
in setting you will get the option.
hth

Originally Posted by mso3

You can set your default signature in your gmail account.
in setting you will get the option.
hth

As far as I can tell, OP is using Outlook, not Gmail?

Originally Posted by xlhelp7

Hi Naveed

Thanks for the reply!

when i run you code it says variable not defined

Regards,

Xlhelp7

hi,

try this code

Sub Email_VBA()
Dim Wkb As Workbook: Set Wkb = ActiveWorkbook
Dim ASht As Worksheet: Set ASht = Wkb.Sheets("Screenshot")
Dim Rng As Range, Rw As Long, LC As Long, Rng2 As Range
Dim SigString As String, Signature As String

With ASht
    Set Rng = .Range("A1:Z500")
End With
Dim OApp As Object, OMail As Object, MyStr As Variant
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.createitem(0)

Subjct = Wkb.Sheets("Product Report").Range("I22").Value

'======================================
snm = "NAVEED" 'signature name which u have given in outlook
SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & snm & ".htm"
If Dir(SigString) <> "" Then
    Signature = GetBoiler(SigString)
Else
    Signature = ""
End If
'===================================
    With OMail
        .Display
        '.SentOnBehalfOfName = ""
        .To = Wkb.Sheets("Product Report").Range("I20").Value
        .CC = Wkb.Sheets("Product Report").Range("I21").Value
        .Subject = Subjct
        '"<P Style='Font-Family:Calibri;Font-Size:11'>"
        '.HTMLBody = strbody
        .HTMLBody = RangetoHTML(Rng) & "<BR>" & Signature
        '.send
    End With
Set OMail = Nothing
Set OApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
Dim fso As Object, ts As Object
Dim TempFile As String, 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
        '.Columns.AutoFit
        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
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    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

Hi Try this below code

Sub email()
Dim mainWB As Workbook
Dim SendID
Dim CCID
Dim Subject
Dim Body
Dim rng1 As Range
 
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
Set mainWB = ActiveWorkbook
SendID = mainWB.Sheets("Product Report").Range("I20").Value
CCID = mainWB.Sheets("Product Report").Range("I21").Value
Subject = mainWB.Sheets("Product Report").Range("I22").Value
Body = mainWB.Sheets("Screenshot").Range("A1:Z500").Value
'======================================
snm = "NAVEED" 'signature name which u have given in outlook
SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & snm & ".htm"
If Dir(SigString) <> "" Then
    Signature = GetBoiler(SigString)
Else
    Signature = ""
End If

'===================================
With olMail
    .To = SendID
    If CCID <> "" Then
      .CC = CCID
    End If
    .Subject = Subject
    mainWB.Sheets("Screenshot").Range("A1:Z500").Copy
    
    Set WrdRng = Doc.Range

    .Display
    WrdRng.Paste
.htmlbody = Signature
    .Display
End With
Sheets("Product Report").Select

End Sub
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    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

Try recording a macro to just send some dummy email and see if the sig gets left off when you run the test macro?

Hi xlhelp7,

Glad to help you

if you happy with the solution then could you please close the thread and click on * Add Reputation to say thank.