macro to save as XLSM and PDF + email PDF RRS feed

  • Question

  • I am using these 2 macros from ron de bruin´s website.

    The first one saves the current workbook as XLSM, while the second one creates a PDF and puts it in an email. The 2 functions are used for the second macro.

    How do I combine into 1 macro, that prompts the user to choose a path and filename, then creates both an XLSM and PDF file, and puts the PDF in a new email?

    Sub save_as_xlsm()
    'Working in Excel 2000-2013
        Dim fname As Variant
        Dim NewWb As Workbook
        Dim FileFormatValue As Long

        'Check the Excel version
        If Val(Application.Version) < 9 Then Exit Sub
        If Val(Application.Version) < 12 Then

            'Only choice in the "Save as type" dropdown is Excel files(xls)
            'because the Excel version is 2000-2003
            fname = Application.GetSaveAsFilename(InitialFileName:="", _
            filefilter:="Excel Files (*.xls), *.xls", _
            Title:="This example copies the ActiveSheet to a new workbook")

            If fname <> False Then
                'Copy the ActiveSheet to new workbook
                Set NewWb = ActiveWorkbook

                'We use the 2000-2003 format xlWorkbookNormal here to save as xls
                NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing

            End If
            'Give the user the choice to save in 2000-2003 format or in one of the
            'new formats. Use the "Save as type" dropdown to make a choice,Default =
            'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
            fname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _
               " Excel Macro Enabled Workbook (*.xlsm), *.xlsm", _
                FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

            'Find the correct FileFormat that match the choice in the "Save as type" list
            If fname <> False Then
                Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
                Case "xlsm": FileFormatValue = 52
                Case Else: FileFormatValue = 0
                End Select

                'Now we can create/Save the file with the xlFileFormat parameter
                'value that match the file extension
                If FileFormatValue = 0 Then
                    MsgBox "Sorry, unknown file extension"
                    'Copies the ActiveSheet to new workbook
                    Set NewWb = ActiveWorkbook

                    'Save the file in the format you choose in the "Save as type" dropdown
                    NewWb.SaveAs fname, FileFormat:= _
                                 FileFormatValue, CreateBackup:=False
                    NewWb.Close False
                    Set NewWb = Nothing

                End If
            End If
        End If
    End Sub

    Sub RDB_Worksheet_Or_Worksheets_To_PDF_And_Create_Mail()
        Dim FileName As String

        If ActiveWindow.SelectedSheets.Count > 1 Then
            MsgBox "There is more then one sheet selected," & vbNewLine & _
                   "be aware that every selected sheet will be published"
        End If

        'Call the function with the correct arguments
        'Tip: You can also use Sheets("Sheet3") instead of ActiveSheet in the code(sheet not have to be active then)
        FileName = RDB_Create_PDF(Sheets("Faktura"), "", True, False)

        'For a fixed file name and overwrite it each time you run the macro use
        'RDB_Create_PDF(ActiveSheet, "C:\Users\Ron\Test\YourPdfFile.pdf", True, False)

        If FileName <> "" Then
            RDB_Mail_PDF_Outlook FileName, "", "", _
                                 "", False
            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 Sub

    Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                            OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
        Dim FileFormatstr As String
        Dim fname As Variant

        'Test If the Microsoft Add-in is installed
        If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
             & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

            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
                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
            Myvar.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    FileName:=fname, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, _
            On Error GoTo 0

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

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

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

        On Error Resume Next
        With OutMail
            .To = StrTo
            .CC = ""
            .BCC = ""
            .Subject = StrSubject
            .Body = StrBody & "<BR>" & .Signature
            .Attachments.Add FileNamePDF
            If Send = True Then
            End If
        End With
        On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing
    End Function

    • Edited by E_stang Friday, November 7, 2014 3:25 PM change of title
    Friday, November 7, 2014 3:24 PM


  • Hi E_stang,

    First, to display a prompt to select file, you could refer to this code below:

    Dim intChoice As Integer
    Dim strPath As String
    'only allow the user to select one file
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Excel Files (*.xls)", "*.xls")
    'make the file dialog visible to the user
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    'determine what choice the user made
    If intChoice <> 0 Then
        'get the file path selected by the user
        strPath = Application.FileDialog( _
        'print the file path to sheet 1
        cells(2, 1) = strPath
    End If

    Secondly, after select a file, you could open that file, the code could be like this:

    Dim oxl As Excel.Application
    Set oxl = CreateObject("Excel.Application")
    Dim oBook As Workbook
            Dim oSheet As Worksheet
            Dim rng As Range
            Set oBook = oxl.Workbooks.Open(strlocation)
            Set oSheet = oBook.Worksheets("Sheet2")

    Thirdly, to combine these macro code, you just need copy the code of RDB_Worksheet_Or_Worksheets_To_PDF_And_Create_Mail to save_as_xlsm (code at last)

    Best Regards


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Monday, November 10, 2014 7:33 AM