Consulting

Results 1 to 2 of 2

Thread: VBA To Attached Signature To Email - Not Working

  1. #1

    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.

    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

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •