VBA To Attached Signature To Email - Not Working

[tkdkidsnake]

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.

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