Problem Adding Email Signature

TkdKidSnake

Board Regular
Joined
Nov 27, 2012
Messages
231
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.

Code:
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
 
Last edited by a moderator:

Forum statistics

Threads
1,078,145
Messages
5,338,507
Members
399,238
Latest member
amuthan10

Some videos you may like

This Week's Hot Topics

Top