Modify the VBA code to exclude text only leave logo from signature

[flora]

Dear Friends,

I have got this code below from this website which is a great piece of code form you gurus.

I need help with modification of this code. I want to add to each email the logo which is in the Thisworkbook.worksheets("TEP").Shapes("Logo")

I tried to modify the Range to html function to include objects but I failed.
then i started using the signature removing all text from the htm signature and only leaving the logo., but i do not know how to do that.

so either to change the range to html to include objects or if this is not possible then to change the blnSignature to remove anything text only leaving logo. either of these will work for me.

any help is apprecited. thank you.

Function SendMessage(strTo As String, Optional strCC As String, _
        Optional strBCC As String, Optional strSubject As String, _
        Optional strMessage As String, Optional rngToCopy As Range, _
        Optional strAttachmentPath As String, _
        Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean, _
        Optional strSentOnBehalfOfName As String)
     
    Dim objOutlook As Object 'Outlook.Application
    Dim objOutlookMsg As Object 'Outlook.MailItem
    Dim objOutlookRecip As Object 'Outlook.Recipient
    Dim objOutlookAttach As Object 'Outlook.Attachment
    Dim lngLoop As Long
    Dim strSignature As String
     
    If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
        MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
        Exit Function
    End If
    
    'Create the Outlook session.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
    Err.Clear: On Error GoTo -1: On Error GoTo 0
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
    End If
     
    'Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(0)


    With objOutlookMsg
        
        'Add the To recipient(s) to the message.
        For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
            If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
                objOutlookRecip.Type = 1 'olTO
            End If
        Next lngLoop
         
        'Add the CC recipient(s) to the message.
        For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
            If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
                objOutlookRecip.Type = 2 'olCC
            End If
        Next lngLoop
         
        'Add the BCC recipient(s) to the message.
        For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
            If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
                objOutlookRecip.Type = 3 'olBCC
            End If
        Next lngLoop

        If strSentOnBehalfOfName <> "" Then
            .SentOnBehalfOfName = strSentOnBehalfOfName
        End If
         
        'Set the Subject, Body, and Importance of the message.
        If strSubject = "" Then
            strSubject = ""
        End If
        .Subject = strSubject
        If strMessage = "" Then
            strMessage = "" & vbCrLf & vbCrLf
        End If
        .Importance = 2 'High importance
        If Not strMessage = "" Then
            .Body = strMessage & vbCrLf & vbCrLf
        End If
        
        If Not rngToCopy Is Nothing Then
            .HTMLBody = .Body & RangetoHTML(rngToCopy)
        End If
         
        'Add attachments to the message.
        For lngLoop = LBound(Split(strAttachmentPath, "|")) To UBound(Split(strAttachmentPath, "|"))
        If Not strAttachmentPath = "" Then
            If Len(Dir(Trim(Split(strAttachmentPath, "|")(lngLoop)))) <> 0 Then
                Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, "|")(lngLoop)))
            Else
                MsgBox "Unable to find the specified attachment '" & Trim(Split(strAttachmentPath, "|")(lngLoop)) & "'. Sending mail anyway."
            End If
        End If
        Next lngLoop
        
        If blnSignature Then
            'Win XP
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
            If Dir(strSignature) = "" Then
            'Win 7
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
            End If
        End If
         
        If Dir(strSignature) <> "" Then
            strSignature = GetBoiler(strSignature)
        Else
            strSignature = ""
        End If
        
        'MsgBox .htmlbody
        .HTMLBody = .HTMLBody & strSignature
            
        'Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
        Next
         
        'Should we display the message before sending?
        If blnShowEmailBodyWithoutSending Then
            .Display
        Else
            .Send
        End If
    End With
     
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookRecip = Nothing
     
End Function

Function RangetoHTML(rng As Range)

    'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim strTempFile As String
    Dim wbkTemp As Workbook

    strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a workbook to receive the data.
    rng.Copy
    Set wbkTemp = Workbooks.Add(1)
    With wbkTemp.Sheets(1)
        With .Cells(1)
            .PasteSpecial Paste:=8
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            .Select
        End With
        Application.CutCopyMode = False
        On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
        Err.Clear: On Error GoTo 0
    End With
 
    'Publish the sheet to an .htm file.
    With wbkTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=strTempFile, _
         Sheet:=wbkTemp.Sheets(1).Name, _
         Source:=wbkTemp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the .htm file into the RangetoHTML subroutine.
    RangetoHTML = GetBoiler(strTempFile)
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close wbkTemp
    wbkTemp.Close SaveChanges:=False
 
    'Delete the htm file.
    Kill strTempFile
 
    Set wbkTemp = Nothing
    
End Function

Function GetBoiler(ByVal strFile As String) As String

    'May not be supported in MAC
    Dim objFSO As Object
    Dim objTextStream As Object
    On Error Resume Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
    GetBoiler = objTextStream.ReadAll
    objTextStream.Close
    
    Set objFSO = Nothing
    Set objTextStream = Nothing
    
End Function

[flora]

I found this code below in the internet, this one you can see that it can pick up range with its image, i tried using the technique below into the above code, but i failed. I appreciate your help.

Private Function RngToEmail(rng As Range, eTo As String, eSubject As String)
    Dim wbThis As Workbook, wbNew As Workbook
    Dim tempFileName As String, imgName As String, newPath As String

    '~~> Do not change "Myimg". This will be used to
    '~~> identify the images
    Dim imgPrefix As String: imgPrefix = "Myimg"

    '~~> This is the temp html file name.
    '~~> Do not change this as when you publish the
    '~~> html file, it will create a folder Temp_files
    '~~> to store the images
    Dim tmpFile As String: tmpFile = "Temp.Htm"

    Set wbThis = Workbooks(rng.Parent.Parent.Name)
    Set wbNew = Workbooks.Add

    '~~> Copy the relevant range to new workbook
    rng.Copy wbNew.Worksheets("Sheet1").Range("A1")

    newPath = wbThis.Path & "\"
    tempFileName = newPath & tmpFile

    '~~> Publish the image
    With wbNew.PublishObjects.Add(xlSourceRange, _
        tempFileName, "Sheet1", rng.Address, xlHtmlStatic, _
        imgPrefix, "")
        .Publish (True)
        .AutoRepublish = True
    End With

    '~~> Close the new file without saving
    wbNew.Close (False)

    '~~> Read the html file in a string in one go
    Dim MyData As String, strData() As String
    Dim i As Long
    Open tempFileName For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)

    '~~> Loop through the file
    For i = LBound(strData) To UBound(strData)
        '~~> Here we will first get the image names
        If InStr(1, strData(i), "Myimg_", vbTextCompare) And InStr(1, strData(i), ".Png", vbTextCompare) Then
            '~~> Insert actual path to the images
            strData(i) = Replace(strData(i), "Temp_files/", newPath & "Temp_files\")
        End If
    Next i

    '~~> Rejoin to get the new html string
    MyData = Join(strData, vbCrLf)

    '~~> Create the Email
    Dim OutApp As Object, OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = eTo
        .Subject = eSubject

        '~~> Set the body
        .HTMLBody = MyData

        '~~> Show the email. Change it to `.Send` to send it
        .Display
    End With

    '~~> Delete the temp file name
    Kill tempFileName
End Function