Emailing Excel Tabs via Outlook and Email Signature

mohammadimran

New Member
Joined
May 30, 2018
Messages
10
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;

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
 
Last edited by a moderator:

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

soadfan

New Member
Joined
Jul 30, 2015
Messages
46
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):

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

Code:
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
 
Last edited:

mohammadimran

New Member
Joined
May 30, 2018
Messages
10
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):

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

Code:
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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,110
Messages
5,835,439
Members
430,357
Latest member
RadStorm20

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
Top