Generate and attach pdf to email without dialogue box

wes2422

New Member
Joined
Feb 8, 2019
Messages
4
This is going to be a long one. I apologize.
I found some VBA script online (this is not something I wrote and can't take credit for any of it) that allows me to export and save the active range as a pdf and it automatically attaches it to an email with some predetermined verbiage. I have another command that I want to incorporate into this. Currently the script takes you to the dialogue box to type in a name you want for the pdf and save the pdf before it attaches to the email. The other command I want to replace it with automatically saves the pdf in the same location with the same name as the excel file and throws a date stamp on it. When I incorporate this command into this it will create the pdf but it wont attach it to the email. I cant seem to figure out how I need to alter the functions to make it work for this command. See existing button command and function below as well as the command I want to use to bypass the dialogue box completely.

Command
Code:
Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
    Dim FileName As String


    If ActiveWindow.SelectedSheets.Count > 1 Then
        MsgBox "There is more then one sheet selected," & vbNewLine & _
               "ungroup the sheets and try the macro again"
    Else
        'Call the function with the correct arguments
        'For a fixed range use this line
        FileName = RDB_Create_PDF(Source:=Range("B1:Z39"), _
                                  FixedFilePathName:="", _
                                  OverwriteIfFileExist:=True, _
                                  OpenPDFAfterPublish:=False)


        'For the selection use Selection in the Source argument
        'FileName = RDB_Create_PDF(Source:=Selection)


        'For a fixed file name use this in the FixedFilePathName argument
        'FixedFilePathName:="C:\Users\Ron\Test\YourPdfFile.pdf"


        If FileName <> "" Then
            RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
                                 StrTo:="", _
                                 StrCC:="", _
                                 StrBCC:="", _
                                 StrSubject:="RDC 3 Week Look Ahead", _
                                 Signature:=True, _
                                 Send:=False, _
                                 StrBody:="All,

" & _
                                          "******>Attached is the three week schedule. Please open the PDF to review." & _
                                          "

" & "Thanks,"
        Else
            MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                   "Microsoft Add-in is not installed" & vbNewLine & _
                   "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                   "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                   "You didn't want to overwrite the existing PDF if it exist"
        End If
    End If
End Sub


[B]FUNCTIONS
[/B]Function RDB_Create_PDF(Source As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant


        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")


            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If


        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If


        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Source.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0


        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End Function






Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
                              StrCC As String, StrBCC As String, StrSubject As String, _
                              Signature As Boolean, Send As Boolean, StrBody As String)
    Dim OutApp As Object
    Dim OutMail As Object


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next
    With OutMail
        If Signature = True Then .Display
        .To = StrTo
        .CC = StrCC
        .BCC = StrBCC
        .Subject = StrSubject
        .HTMLBody = StrBody & "
" & .HTMLBody
        .Attachments.Add FileNamePDF
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0


    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

What I want to incorporate
Code:
Sub ExportPDF()
    Dim sFile As String
    sFile = ThisWorkbook.Path & "" & ActiveWorkbook.Name & Format(Date, "mm-dd-yy")
    
    Sheets("Sheet1").Select
    ActiveSheet.PageSetup.PrintArea = "$B$1:$Z$39"
   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
      FileName:=sFile, Quality:=xlQualityStandard, _
      IncludeDocProperties:=True, IgnorePrintAreas:=False, _
      OpenAfterPublish:=True
End Sub
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Watch MrExcel Video

Forum statistics

Threads
1,122,909
Messages
5,598,796
Members
414,259
Latest member
beetle12

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
Top