Problem Adding Email Signature

[TkdKidSnake]

Hi all,

I have the following code and all is working ok, apart from it is no longer adding my set signature in Outlook . If possible could you have a look and amend as required.

Sub ScorecardPdfEmail()



  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 = "[B][B]Dear Supplier,[/B][/B]

" & _
              "Attached is our latest Scorecard for yourselves which has now been updated to include all
" & _
              "the relevant data transactions from the previous month.
" & _
              "Please review and contact me or any member of the management team here
" & _
              "at JJS Manufacturing if you would like to discuss further.
" & _
              "

[B]Thank you for your continued support.
[/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 = & " < 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

Any help you can provide would be greatly appreciated.

Thanks in advance