VBA To Attached Signature To Email - Not Working
Hi all,
I wonder if anyone can help, I have the code below which does exactly what I want it to however when it comes to trying to add the default email signature at the bottom of the email for some reason this isn't working - would it be possible for someone to take a look and either advise whats wrong or advise another way of doing this.
Code:
Sub PDFScorecardEmailPDF()
Dim OutApp As Object, OutMail As Object
Dim fname As String, sendto As String, sendcc As String, sendbcc As String
Dim sendsubject As String, sendbody As String
Dim sh As Worksheet, fPath As String, i As Long
'
fPath = "\\pel.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\"
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To Sheets.Count
If Evaluate("ISREF('" & "S" & i & "'!A1)") Then
Set sh = Sheets("S" & i)
fname = sh.Range("AL1") & sh.Range("AE4").Value & ".pdf"
'Work Location
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fname, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'Check email text below
sendto = sh.Range("AE16").Value
sendcc = Sheets("Emails").Range("D403").Value
sendbcc = Sheets("Emails").Range("D405").Value
sendsubject = sh.Range("AE4").Value
sendbody = "<H3><B>Dear Supplier,</B></H3>" & _
"Attached is our latest Scorecard for yourselves which has now been updated to include all<br>" & _
"the relevant data transactions from the previous month.<br><br>" & _
"Please review and contact me or any member of the management team here<br>" & _
"at JJS Manufacturing if you would like to discuss further.<br>" & _
"<br><br><B>Thank you for your continued support.<br></B>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sendto
.Cc = sendcc
.Bcc = sendbcc
.Subject = sendsubject
.HTMLBody = sendbody & " < br > " & .HTMLBody
.Attachments.Add fPath & fname
.Display
'.send
End With
On Error GoTo 0
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Sheets("Data Entry").Select
End Sub
I have also had to put some spaces in the BR section so it displays sort of correctly on here.
Any help you can provide would be greatly appreciated as i am turning more grey as the minutes pass by.
Thanks in advance
