Excel Forum

VBA auto email in Excel file format

David_Ng

Member

Members

Forum Posts: 306

Member Since:
December 5, 2016

Offline

February 3, 2021 - 2:12 pm

The following VB codes work fine to send pdf file to individual recipient based on Pivot Fields, deep thanks to Philip.

But, can these codes be modified send pivot field filtered range in Excel File format, not pdf format to recipient.

Option Explicit

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

    ' *****     You Can Change The Values of These Variables    *********
    EmailSubject = "Outstanding POs copy in NAS " '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("Pivot Table").PivotTables("PivotTable1")
    pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
    pt.PivotCache.Refresh

    Set pf = pt.PivotFields("PIC")

    Set OutlookApp = CreateObject("Outlook.Application")

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

    With ActiveSheet.PageSetup
        .PrintTitleRows = "$3:$3"
        .FitToPagesWide = 15
        .FitToPagesTall = 15
        .Orientation = xlLandscape
         .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)

    End With

    Application.PrintCommunication = True

' Go through every Staff 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 Staff 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 GoTo 0

 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

 ''On Error GoTo 0
 On Error Resume Next

 '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

.htmlbody = "Dear POs PIC,"
.htmlbody = .htmlbody & "Good day !"
.htmlbody = .htmlbody & "Attached please subject list as of today, please help to store the POs soonest."
.htmlbody = .htmlbody & "Best Regards, "
.htmlbody = .htmlbody & "David "
.htmlbody = .htmlbody & "ABC Ltd."

            .Display
            .To = WorksheetFunction.VLookup(Range("B1").Value, Worksheets("Staffs").Range("Managers"), 2, False)
            'To = WorksheetFunction.VLookup(Range("B2").Value, Worksheets("Staffs").Range("Staffs"), 2)
            '.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 = True 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