ADD EMAIL SIGNATURE (including company logo pic) TO NEW EMAILS

[JuicyMusic]

Hello again, I have a code that generates emails. Could you please show me how to include my saved email signature on every newly generated email?

The name of my email signature is "MyComplianceSig". It is saved in Outlook.

Here is my code in full. Thank you!

Sub Split_Data_Into_TabsGENEMAILPERCENT_pcsignCG()
    Dim lr As Long, ws As Worksheet, vcol, i As Integer, icol As Long, myarr As Variant, title As String, titlerow As Integer
    Dim OutApp As Object, OutMail As Object, rng As Range, lVisRow As Long
    ' Line to add Subject line in email
    Dim Subject As String
    ' cc recipient added
    Dim cc_ As String, bcc_ As String
    'Line to add signature to email - Name it "MyComplianceSig"
    
    
    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    Set OutApp = CreateObject("Outlook.Application")
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        lVisRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            Sheets(myarr(i) & "").Columns.AutoFit
            Set rng = Sheets(myarr(i) & "").UsedRange
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = ""
                .cc = "Safety@kgcinc.com"
                .Subject = "Safety Compliance Check for " & "" & Range("A1").Value
                .htmlBody = "Hello " & Left(Range("A3"), InStr(Range("A3"), " ") - 1) & ", " & "<br><br>" _
                    & "Here are your results for the month:" & "<br><br>" _
                    & "Performance Results for JSA:  " & Format(ws.Range("K" & lVisRow) / 10 * 10, "0%") & "<br>" _
                    & "Performance Results for TAILGATE:  " & Format(ws.Range("R" & lVisRow) / 10 * 10, "0%") & "<br>" _
                    & "Performance Results for PANDEMIC:  " & Format(ws.Range("Y" & lVisRow) / 10 * 10, "0%") & "<br><br>" _
                    & "Below is the Monthly Safety Compliance Breakdown " & _
                    "and your JSA's. Tailgate Meetings and COVID-19 checklists are attached with feedback for your review." _
                    & "<br><br>" & "Here is our feedback regarding your monthly JSA's, Tailgates, and COVID-19 checklists:" & "<br><br>" _
                    & ">>" & "<br>" _
                    & ">>" & "<br>" _
                    & ">>" & "<br>" _
                    & ">>" & "<br>" _
                    & RangetoHTML(rng) & "<br><br>" & "Please let me know if you have any questions or concerns regarding this information."
                .Display
            End With
        Else
            Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        End If
    Next i
    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
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"
    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
    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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function