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

[tkdkidsnake]

I have managed to sort this, all I have done is move the .Display to underneath With OutMail and its now working again.