how to add my signature with images to macro

[atditiljazi]

Hello everyone, please find my macro below. Is there a method for including my Outlook signature that holds images? I am struggling to figure it out for myself.

i will be grateful for your help

Sub send_email()

Dim rng As Range, c As Range, AddrRange As Range
Dim i As Long, lastRow As Long, lastRow2 As Long
Dim targetWorkbook As Workbook
Dim objFSO As Object
Dim varTempFolder As Variant, v As Variant
Dim AttFile As String, Dest As String, myCC As String
Dim sh As Worksheet, shMail As Worksheet

Set sh = Sheets("order book")
Set shMail = Sheets("Sheet2")

lastRow = sh.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastRow2 = shMail.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set AddrRange = shMail.Range("A1:a" & lastRow2)

v = sh.Range("A2:v" & lastRow).Value

Set objFSO = CreateObject("Scripting.FileSystemObject")
varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
objFSO.CreateFolder (varTempFolder)

Application.ScreenUpdating = False

With CreateObject("scripting.dictionary")

For i = 2 To UBound(v)
    If Not .exists(v(i, 2)) Then
        .Add v(i, 2), Nothing

        With sh
            .Range("A1").AutoFilter 2, v(i, 2)
            Set rng = .AutoFilter.Range
           Set targetWorkbook = Workbooks.Add
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy
        End With
         
         With targetWorkbook.Worksheets(Sheets.Count)
            .Range("A1").PasteSpecial xlPasteColumnWidths
            .Range("A1").PasteSpecial xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            .Range("A1").PasteSpecial xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End With
                    
        AttFile = v(i, 2) & ".xlsx"
    
        On Error Resume Next
        r = 0
        r = Application.WorksheetFunction.Match(v(i, 2), AddrRange, 0)
        On Error GoTo 0
        
        If r > 0 Then
            With shMail
                Dest = .Range("B" & r)
                myCC = .Range("C" & r)
            End With
        
        
            With targetWorkbook
                '.ActiveSheet.Columns.AutoFit
                .SaveAs varTempFolder & "" & AttFile
                .Close
            End With
        
            With CreateObject("Outlook.Application").CreateItem(0)
    .To = Dest
    .CC = myCC
    .Subject = "order book"
    .Body = "Please find an open order book attached.In column L, please enter the expected delivery date. In column M, please enter the confirmed quantity.Please confirm the unit cost in column N.Please enter any comments in Column O, for example, if an order is delayed, please enter the reason why.If an order is Free Issue, please disregard the cost column. Please return the spreadsheet as soon as possible so that I can update my system accordingly. Kind Regards. Ardit Iljazi "
    
    ' Add sentence breaks
    .Body = Replace(.Body, ".", "." & vbCrLf)
    
    .Attachments.Add varTempFolder & "" & AttFile
    '.display 'to show
    .Send 'to send
End With

        Else
            MsgBox v(i, 2) & " not found.", vbExclamation
            Exit For
        End If
    End If
Next i
End With

Range("A1").AutoFilter
Application.ScreenUpdating = True

objFSO.deletefolder (varTempFolder)
End Sub

 

[Domenic]

If you have it set up so that your signature is automatically added to any newly created email, try the following...

With CreateObject("Outlook.Application").CreateItem(0)
    .To = Dest
    .CC = myCC
    .Subject = "order book"
   
    ' Get the existing signature from the email
    Dim signature As String
    signature = .htmlbody
   
    .Body = "Please find an open order book attached.In column L, please enter the expected delivery date. In column M, please enter the confirmed quantity.Please confirm the unit cost in column N.Please enter any comments in Column O, for example, if an order is delayed, please enter the reason why.If an order is Free Issue, please disregard the cost column. Please return the spreadsheet as soon as possible so that I can update my system accordingly. Kind Regards. Ardit Iljazi "
   
    ' Add sentence breaks
    .Body = Replace(.Body, ".", "." & vbCrLf)
   
    .htmlbody = .htmlbody & signature
   
    .Attachments.Add varTempFolder & "" & AttFile
    .display 'to show
    '.Send 'to send
End With

Hope this helps!