VBA send email from excel/outlook and attach signature

[kizzie37]

I'm using Ron De Bruin's code fro sending a list via email from excel. but my signature does not attach to the email. There is another code for sending an email with the signature, however I don't know how to marry the 2 together. both codes are below, Can anyone assist with just attaching my signature to the existing code? (my signature has pictures in it)


Sub Send_Row_Or_Rows_1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim strbody As String

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:F" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set OutMail = OutApp.CreateItem(0)
strbody = "Please find attached the gross earnings register for your team for March 13th" & vbNewLine & vbNewLine & _
" " & "<br>" & _
" " & "<br>" & _
"If you notice any errors, please report as soon as possible" & vbNewLine & _



On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "Payroll Gross Earnings Report"
.HTMLBody = strbody & RangetoHTML(rng)

.Send 'Or use Send
End With
On Error GoTo 0

Set OutMail = Nothing
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Sub Mail_Outlook_With_Signature_Html_1()
' Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""Excel for Windows Tips"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"

On Error Resume Next

With OutMail
.Display
.To = "vap.tracy.francis@hubinternational.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br>" & .HTMLBody
.Send
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[kizzie37]

Please can anyone help? Ive tried to find the answer elsewhere but just keep disappearing down a rabbit hole