Not Attaching PDF

jamesmev

Board Regular
Joined
Apr 9, 2015
Messages
233
Office Version
  1. 365
Platform
  1. Windows
i am using the following to copy a sheet -
Place specific Ranges within the body of an email
and attach a pdf of the sheet to the email. However, it will not attach a pdf.
When I run it gives a publishing prompt - creates the email - no PDF.
****************************************
Sub Send_PDF_As_Email()
Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
Set Cell3 = Range("X10") 'email recipient
Sheets("Dashboard").Select
Range("D5").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""X"")"
Range("D6").Select
Sheets("Cona Forms").Select
Range("E229:J229").Select
' file will be saved before
' sending it in email by attaching it.


TempFilePath = Environ$("temp") & ""


' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.


TempFileName = "Equipment Control Request Form" & Format(Now, " dd-mmm-yyyy") & ".pdf"


'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName


'Now Export the Activesshet as PDF with the given File Name and path


With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
'Now open a new mail


Set OlApp = CreateObject("Outlook.Application")
Set NewMail = OlApp.CreateItem(0)


On Error Resume Next




' -----------------------------------------------------------------------------------------
Call Format_HTML_Table_For_Outlook(strTable, strHdr)
''' Set objMessage = CreateObject("CDO.Message")
Strbody = Strbody & strTable

Strbody = Strbody & "<br><br><br><br><br>" & _
"<font size=1>" & _
"Development Reference:" & "<br>" & _
"Email generated using " & """" & ActiveWorkbook.Name & """" & "<br>" & _
"Userid: " & UserName & "<br>" & _
"Excel: " & Excel_Version & " running on " & _
OS_Caption & " - " & OS_Version & "<br>" & _
"</font><br>"
' -----------------------------------------------------------------------------------------




With NewMail
.To = Cell3.Value

.CC = ""
.BCC = ""
.Subject = strHdr
.HTMLBody = Strbody
.Attachments.Add PdfFile
.Display
'' .Send
Sheets("Cona Forms").Activate
MsgBox "Go To Outlook.", vbInformation, "Message"
End With


' Delete PDF file


Kill PdfFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub


Function Format_HTML_Table_For_Outlook(strTable, strHdr)
strTable = ""
strHdr = ""
Sheets("Dashboard").Select
Cor_Req = Cells(5, 3).Value
Client = Cells(3, 3).Value
Plant = Cells(4, 3).Value
Serial = Cells(8, 3).Value
strTable = strTable & "<b>Correction Request : " & Cor_Req & "</b><br></b><br>"
strTable = strTable & "Client : " & Client & "</b></b><br>"
strTable = strTable & "Plant : " & Plant & "</b><br></b><br>"
strTable = strTable & "<Table> <TBody>" ' HTML Table Begin
strTable = strTable & "<tr> <th>Correction </th> <th>Required Information</th> </tr>"
For pctr = 7 To 78
If Rows(pctr & ":" & pctr).EntireRow.Hidden = False _
Then
fld1 = Cells(pctr, 2)
fld2 = Cells(pctr, 3)
strHdr = "Correction Request : " & Cor_Req & ", Plant : " & Plant & ", Serial # : " & Serial
strTable = strTable & "<tr> <td> " & _
fld1 & _
"</td><td>" & _
fld2 & "</td> </tr>"
End If
Next
strTable = strTable & "</TBody> </Table>" ' HTML Table End

End Function
********************************************

Any Help here?
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
I don't know what character did not show. Backslash is the usual one. Use code tags and paste code between. Click the # icon on reply toolbar to insert the tags.
Code:
TempFilePath = Environ$("temp") & "\"
 
Upvote 0
I don't know what character did not show. Backslash is the usual one. Use code tags and paste code between. Click the # icon on reply toolbar to insert the tags.
Code:
TempFilePath = Environ$("temp") & "\"
Code:
   Sub Send_PDF_As_Email()   Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFullPath As String
 Set Cell3 = Range("X10")  'email recipient
      Sheets("Dashboard").Select
    Range("D5").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""X"")"
    Range("D6").Select
    Sheets("Cona Forms").Select
    Range("E229:J229").Select
' file will be saved before
' sending it in email by attaching it.


    TempFilePath = Environ$("temp") & "\"


' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.


    TempFileName = "Equipment Control Request Form" & Format(Now, " dd-mmm-yyyy") & ".pdf"


'Complete path of the file where it is saved
    FileFullPath = TempFilePath & TempFileName


'Now Export the Activesshet as PDF with the given File Name and path


        With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With
'Now open a new mail


    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)


    On Error Resume Next
 


    
    ' -----------------------------------------------------------------------------------------
   Call Format_HTML_Table_For_Outlook(strTable, strHdr)
'''    Set objMessage = CreateObject("CDO.Message")
    Strbody = Strbody & strTable
    
       Strbody = Strbody & "<br><br><br><br><br>" & _
             "<font size=1>" & _
              "Development Reference:" & "<br>" & _
              "Email generated using " & """" & ActiveWorkbook.Name & """" & "<br>" & _
              "Userid: " & UserName & "<br>" & _
              "Excel: " & Excel_Version & " running on " & _
                          OS_Caption & " - " & OS_Version & "<br>" & _
              "</font><br>"
    ' -----------------------------------------------------------------------------------------




With NewMail
    .To = Cell3.Value
    
    .CC = ""
    .BCC = ""
    .Subject = strHdr
    .HTMLBody = Strbody
    .Attachments.Add PdfFile
    .Display
''    .Send
     Sheets("Cona Forms").Activate
    MsgBox "Go To Outlook.", vbInformation, "Message"
End With


' Delete PDF file


  Kill PdfFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub


Function Format_HTML_Table_For_Outlook(strTable, strHdr)
    strTable = ""
    strHdr = ""
    Sheets("Dashboard").Select
    Cor_Req = Cells(5, 3).Value
    Client = Cells(3, 3).Value
    Plant = Cells(4, 3).Value
    Serial = Cells(8, 3).Value
    strTable = strTable & "<b>Correction Request : " & Cor_Req & "</b><br></b><br>"
    strTable = strTable & "Client : " & Client & "</b></b><br>"
    strTable = strTable & "Plant : " & Plant & "</b><br></b><br>"
    strTable = strTable & "<Table> <TBody>"     ' HTML Table Begin
    strTable = strTable & "<tr> <th>Correction </th> <th>Required Information</th> </tr>"
    For pctr = 7 To 78
        If Rows(pctr & ":" & pctr).EntireRow.Hidden = False _
        Then
           fld1 = Cells(pctr, 2)
           fld2 = Cells(pctr, 3)
            strHdr = "Correction Request : " & Cor_Req & ", Plant : " & Plant & ", Serial # : " & Serial
        strTable = strTable & "<tr> <td> " & _
                   fld1 & _
                   "</td><td>" & _
                   fld2 & "</td> </tr>"
        End If
    Next
    strTable = strTable & "</TBody> </Table>"   ' HTML Table End
    
End Function

Thank you
 
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top