Emailing Excel Tabs via Outlook and Email Signature

[mohammadimran]

Hello Seniors,

I am trying to use VBA to send all the excel tabs as outlook emails. Everything is working fine except email signatures. the signature text is coming along just fine however the company image that I need does not show up and neither are the twitter and facebook handle icon images show up and instead a box with cross on left corner shows up in my email signature for all the emails that I send. What to do to fix this issue. Below is the code;

Sub Outlook_Mail_Every_Worksheet_Body()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim StrBody As String


Dim OApp As Object, OMail As Object, signature As String
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OMail
.Display
End With
signature = OMail.htmlbody


With OMail

End With
Set OMail = Nothing
Set OApp = Nothing


    


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set OutApp = CreateObject("Outlook.Application")
    
    StrBody = "Hello Team," & "
" & _
              "Please refer to the mentioned PO and RMA number. We are looking for credits on these return requests." & "

" & _
              "Thank you for your support!" & "

"
                        




    For Each ws In ActiveWorkbook.Worksheets
        If ws.Range("A1").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)


            On Error Resume Next
            With OutMail
                .To = ws.Range("A1").Value
                .CC = "myname@mycompany.com; [EMAIL="mygroup@mycompany.com"]mygroup@mycompany.com[/EMAIL]"
                .BCC = ""
                .Subject = ws.Range("I1").Value
                
                
                .htmlbody = StrBody & RangetoHTML(ws.UsedRange) & signature
               
                .Send    'or use .Display
            End With
            On Error GoTo 0


            Set OutMail = Nothing
        End If
    Next ws


    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
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"
    


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

 

[mohammadimran]

Can someone please help on this one?

 

[Wanderer_geologist]

Why don t you create the signature with picture in outlook directly ?

 

[soadfan]

Why don t you create the signature with picture in outlook directly ?

Yeah, make your signature via outlook options.

After that you need getBoiler (i found it on google):

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

then

strFolder = Environ("appdata") & "\Microsoft\Signatures\"
strPattern = "*.htm"
SigString = strFolder & Dir(strFolder & strPattern, vbNormal)
If Dir(SigString) <> "" Then
   Signature = GetBoiler(SigString)
Else
   Signature = ""
End If

This code will find the very first htm file where OL saves it's signatures > C:\Users\YOUR-PC-USERNAME\AppData\Roaming\Microsoft\Signatures

You also may need to edit that htm and convert all image paths from relative to absolute (full path) and first .display and then .send

 

[mohammadimran]

I already have the picture saved in my outlook signatures. Tried this solution but didn't work. still on square 1

Yeah, make your signature via outlook options.

After that you need getBoiler (i found it on google):

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

then

strFolder = Environ("appdata") & "\Microsoft\Signatures\"
strPattern = "*.htm"
SigString = strFolder & Dir(strFolder & strPattern, vbNormal)
If Dir(SigString) <> "" Then
   Signature = GetBoiler(SigString)
Else
   Signature = ""
End If

This code will find the very first htm file where OL saves it's signatures > C:\Users\YOUR-PC-USERNAME\AppData\Roaming\Microsoft\Signatures

You also may need to edit that htm and convert all image paths from relative to absolute (full path) and first .display and then .send