Send email using pivot table and VBA

[BODYCOTE]

Hello,

I am currently using the below vba to send orders from my pivot table through outlook, but I want to know what I need to change to allow me to have a pre-written body for the email, without losing the default signature that outlook is using.

Thanks for any help.

Option Explicit

' Written by Philip Treacy - MyOnlineTrainingHub
' https://www.myonlinetraininghub.com/automating-emailing-pivot-table-reports

Sub EmailPTReports()

Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim i As Long
Dim EmailSubject As String
Dim PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim DisplayEmail As Boolean
Dim OutlookApp As Object, OutlookMail As Object
Dim strbody As String

' ***** You Can Change The Values of These Variables *********
EmailSubject = "Order" 'Change this to change the subject of the email.
DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work
Email_To = "" 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = ""
Email_BCC = ""
' ******************************************************

Set pt = Sheets("PURCHASE ORDER BY SUPPLIER").PivotTables("PivotTable2")
pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
pt.PivotCache.Refresh

Set pf = pt.PivotFields("SUPPLIER NAME")

Set OutlookApp = CreateObject("Outlook.Application")


' Setup the sheet to print one 1 page
Application.PrintCommunication = False

With ActiveSheet.PageSetup

.FitToPagesWide = 1
.FitToPagesTall = 1
.Orientation = xlPortrait

End With

Application.PrintCommunication = True

' Go through every category in turn
For i = 1 To pf.PivotItems.Count

pf.CurrentPage = pf.PivotItems(i).Name
PDFFile = Environ("Temp") & Application.PathSeparator & pf.PivotItems(i).Name & ".pdf"

' Replace / in category name as this is an invalid character for filenames
PDFFile = Replace(PDFFile, "/", "_")

' Delete PDFFile if it already exists so that
' we can create new file later with the same name
On Error Resume Next
If Len(Dir(PDFFile)) > 0 Then Kill PDFFile

' If there's an error deleting the file
If Err.Number <> 0 Then

MsgBox "Unable to delete " & PDFFile & ". Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"

Exit Sub

End If

' Reset error handling to normal
On Error GoTo 0

'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

'Create a new mail message
Set OutlookMail = OutlookApp.CreateItem(0)

'Display email and specify To, Subject, etc
With OutlookMail

.Display
.To = WorksheetFunction.VLookup(Range("C5").Value, Worksheets("SUPPLIERS").Range("TABLE6"), 3)
'.CC = Email_CC
'.BCC = Email_BCC
.Subject = EmailSubject
.Attachments.Add PDFFile

' Change this to True to automatically send emails without first viewing them
If DisplayEmail = False Then

.Send

End If

End With

' Delete the temp file we just created
Kill PDFFile

Next i

' Tidy up
Set OutlookApp = Nothing
Set OutlookMail = Nothing

End Sub