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?
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?