Default Signature with Image

Hello experts,

I have been trying to get my default outlook signature to appear, but I'm unsuccessful in making the image inside it to appear (the rest of the signature works fine).

I know this is a topic that probably has been answered already, but I couldn't adapt any answer so far.

Here's the code:

Sub logistic()

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

    'avoid multiple selections
    If Selection.Count = 1 Then
    Else
    Exit Sub
    End If

Dim sup_range As Range
Dim sup_type As Variant
Dim settings As Worksheet
Dim sup_contact As Variant
Dim sup_data As Variant
Dim activeloc As Variant
Dim iata As Variant
Dim suplistr As Variant
Dim suplistc As Variant
Dim singmult As Variant
Dim supname As Variant
Dim suptype As Variant
Dim supcontact As Variant
Dim airreg As Variant
Dim oprt As Variant
Dim icao As Variant
Dim cn As Variant

Set settings = ThisWorkbook.Worksheets("Settings")
iata = settings.Cells(7, 21)
suplistr = settings.Cells(37, 20)
suplistc = settings.Cells(37, 21)
singmult = settings.Cells(40, 21)
supname = settings.Cells(11, 21)
suptype = settings.Cells(39, 21)
supcontact = settings.Cells(38, 21)
airreg = settings.Cells(6, 21)
oprt = settings.Cells(5, 21)
icao = settings.Cells(15, 21)
cn = settings.Cells(34, 21)

first_row = 2
Set activeloc = ThisWorkbook.ActiveSheet.Cells(ActiveCell.Row, iata)

Set sup_range = settings.Range(settings.Cells(suplistr - 1, suplistc), settings.Cells(settings.Cells(suplistr - 1, suplistc).End(xlDown).Row, singmult))
sup_type = Application.VLookup(Cells(ActiveCell.Row, supname).Value, sup_range, suptype - 1, False)
sup_contact = Application.VLookup(Cells(ActiveCell.Row, supname).Value, sup_range, supcontact - 1, False)
sup_data = Application.VLookup(Cells(ActiveCell.Row, supname).Value, sup_range, singmult - 1, False)

If IsError(sup_type) Then
MsgBox ("Not found")
Exit Sub
Else
End If

If sup_type <> "Email" Then
MsgBox ("Contact by " & sup_type)
Exit Sub
End If

    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim excel_body As Range
    Dim headers As Range
    Set headers = Range(Cells(first_row, airreg), Cells(first_row, airreg + 6))
    
If sup_data = "Single" Then
    'Select cells that are to be sent, add temp sheet to rearrange info
    Set excel_body = Range(Cells(ActiveCell.Row, airreg), Cells(ActiveCell.Row, airreg + 6))
    headers.Select
    Selection.Copy
    Sheets.Add after:=ActiveSheet
    ActiveSheet.Paste
    Rows(2).Select
    ActiveSheet.Previous.Select
    excel_body.Select
    Selection.Copy
    ActiveSheet.Next.Select
    ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlValues
    ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlFormats
    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells(1, 1).Select
    Application.CutCopyMode = False
    ActiveSheet.Name = "Claim Info"
    Set excel_body = Range(Cells(1, 1), Cells(Cells(1, 1).End(xlDown).Row, Cells(1, 1).End(xlToRight).Column))
    
    ActiveSheet.Previous.Select
    TempFileName = Cells(ActiveCell.Row, oprt).Value & Cells(ActiveCell.Row, iata).Value _
    & "/" & Cells(ActiveCell.Row, icao).Value

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Dim mail_body_message As String
    
    'still need to correct
    mail_body_message = settings.Cells(10, 16).Text & _
    Cells(ActiveCell.Row, iata).Value & "/" & Cells(ActiveCell.Row, icao).Value & settings.Cells(11, 16).Text
    
Else
    ActiveSheet.Range(Cells(first_row, 1), Cells(Cells(first_row, oprt).End(xlDown).Row, cn)).AutoFilter Field:=airreg, _
    Criteria1:=Cells(ActiveCell.Row, airreg).Value
    
    'Select cells that are to be sent, add temp sheet to rearrange info
    Set excel_body = Range(Cells(ActiveCell.Row - 1, airreg), Cells(ActiveCell.Row + 2, airreg + 6))
    headers.Select
    'excel_body.Select
    Selection.Copy
    Sheets.Add after:=ActiveSheet
    ActiveSheet.Paste
    Rows(2).Select
    ActiveSheet.Previous.Select
    excel_body.Select
    Selection.Copy
    ActiveSheet.Next.Select
    ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlValues
    ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlFormats
    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells(1, 1).Select
    'Rows(ActiveCell.Row + 1).Select
    
    Columns(2).Select
    Selection.Find(What:=activeloc, after:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.EntireRow.Select
   
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
        Application.CutCopyMode = False
    ActiveSheet.Name = "Claim Info"
    
    Set excel_body = Range(Cells(1, 1), Cells(Cells(1, 1).End(xlDown).Row, Cells(1, 1).End(xlToRight).Column))
    
    ActiveSheet.Previous.Select
    TempFileName = Cells(ActiveCell.Row + 1, oprt).Value & & Cells(ActiveCell.Row + 1, iata).Value _
    & "/" & Cells(ActiveCell.Row + 1, icao).Value

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    mail_body_message = Cells(ActiveCell.Row + 1, iata).Value & "/" & Cells(ActiveCell.Row + 1, icao).Value
    
    End If
        
    On Error Resume Next
    With OutMail
            .To = sup_contact
            .CC = ""
            .BCC = ""
            .Subject = TempFileName
            .HTMLbody = mail_body_message & "<br>" & RangetoHTML(excel_body) & "<br>" & "Regards"
            
            'If MsgBox("Do you want to review the e-mail?", vbYesNo) = vbYes Then
                .Display
             '   Else
             '   .Send
           ' End If
        End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    If ActiveSheet.AutoFilterMode Then
    ActiveSheet.AutoFilter.ShowAllData
    Else
    End If

Worksheets("Claim info").Delete
'ActiveSheet.Previous.Activate
Application.CutCopyMode = False
activeloc.Select

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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 xlPasteAll, , False, False
        '.Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Range(Columns(1), Columns(7)).EntireColumn.AutoFit
        .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

Thank you for your help.

I tried before that solution, but I was not aware that the display at the beginning was necessary (it had the display at the end, so I didn't see the problem)

Too bad about the flicker it produces but at least the result is what I had in mind.

Thank you for your help.