SavePDF Macro

gistfile1.vb

Option Explicit
Public Sub SavePDF(Optional ExportLocation As String, _
    Optional AskForDestination As Boolean = False, _
    Optional OpenAfterExport As Boolean = False)
'
' SavePDF Macro
'
' GetFolder based on original code from: http://www.mrexcel.com/forum/showthread.php?t=294728
' TrimToChar based on original code from: http://www.cpearson.com/excel/sizestring.htm

    ' Initialize variables
    Dim bPrintHiddenTextState As Boolean
    Dim strPath As String
    Dim strFilename As String
    
    ' Store initial PrintHiddenText state
    bPrintHiddenTextState = Options.PrintHiddenText

    ' Set destination folder and filename
    strPath = ExportLocation
    If strPath = vbNullString Then
        strPath = ActiveDocument.Path
    End If
    strFilename = TrimToChar(ActiveDocument.Name, ".", True)
    If AskForDestination = True Then
        strPath = GetFolder(strPath)
    End If
    
    ' Turn on hidden text
    Options.PrintHiddenText = True
    
    ' Perform export
    ActiveDocument.ExportAsFixedFormat OutputFileName:=strPath + "\" + strFilename, _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=OpenAfterExport, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    
    ' Return PrintHiddenText to initial state
    Options.PrintHiddenText = bPrintHiddenTextState
    
End Sub

Public Function TrimToChar(Text As String, TrimChar As String, _
    Optional SearchFromRight As Boolean = False) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TrimToChar
' This function returns the portion of the string Text that is to the left of
' TrimChar. If SearchFromRight is omitted or False, the returned string
' is that string to the left of the FIRST occurrence of TrimChar. If
' SearchFromRight is True, the returned string is that string to the left of the
' LAST occurrance of TrimToChar. If TrimToChar is not found in the string,
' the entire Text string is returned. TrimChar may be more than one character.
' Comparison is done in Text mode (case does not matter).
' If TrimChar is an empty string, the entire Text string is returned.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim Pos As Integer

    ' Test to see if TrimChar is vbNullString. If so, return the whole string. If we
    ' don't test here and used InStr as in the next logic block, an empty string would
    ' be returned.
    If TrimChar = vbNullString Then
        TrimToChar = Text
        Exit Function
    End If

    ' find the position in Text of TrimChar
    If SearchFromRight = True Then
        ' search right-to-left
        Pos = InStrRev(Text, TrimChar, -1, vbTextCompare)
    Else
        ' search left-to-right
        Pos = InStr(1, Text, TrimChar, vbTextCompare)
    End If
    ' return the sub string
    If Pos > 0 Then
        TrimToChar = Left(Text, Pos - 1)
    Else
        TrimToChar = Text
    End If

End Function
Public Sub SavePDFSilently()
    SavePDF vbNullString
End Sub
Public Sub SavePDFAndReview()
    SavePDF vbNullString, True, True
End Sub
Public Function GetFolder(InitDir As String) As String
    Dim fldr As FileDialog
    Dim sItem As String

    sItem = InitDir
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If Right(sItem, 1) <> "\" Then
            sItem = sItem & "\"
        End If
        .InitialFileName = sItem
        If .Show <> -1 Then
            sItem = InitDir
        Else
            sItem = .SelectedItems(1)
        End If
    End With

    GetFolder = sItem
    Set fldr = Nothing
End Function