Thread: [Solved] Save as PDF with bookmarks
View Single Post
 
Old 08-19-2016, 09:00 PM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

No, it will overwrite the existing file. If you want a prompt you will need extra code and you will have to determine what to do in that eventuality. My recommendation is to append a number to the file name, which is what the following will do:

Code:
Sub Macro1()
Dim strPath As String
Dim strDocname As String
Dim lngAsk As Long
    strPath = "C:\Path\"
    strDocname = "MyPDF.pdf"
    If FileExists(strPath & strDocname) Then
        lngAsk = MsgBox(strPath & strDocname & " already exists. Do you wish to overwrite the file?", vbYesNo)
        If Not lngAsk = vbYes Then
            strDocname = strPath & FileNameUnique(strPath, strDocname, "pdf")
        Else
            strDocname = strPath & strDocname
        End If
    Else
        strDocname = strPath & strDocname
    End If
    ActiveDocument.ExportAsFixedFormat OutputFilename:=strDocname, _
                                       ExportFormat:=wdExportFormatPDF, _
                                       OpenAfterExport:=False, _
                                       OptimizeFor:=wdExportOptimizeForPrint, _
                                       Range:=wdExportAllDocument, From:=1, to:=1, _
                                       Item:=wdExportDocumentContent, _
                                       IncludeDocProps:=True, _
                                       KeepIRM:=True, _
                                       CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                       DocStructureTags:=True, _
                                       BitmapMissingFonts:=True, _
                                       UseISO19005_1:=False
End Sub

Public Function FileNameUnique(strPath As String, _
                               strFileName As String, _
                               strExtension As String) As String
'Graham Mayor - http://www.gmayor.com
'Requires the use of the FileExists function
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strextension is the extension of the filename to check
Dim lngF As Long
Dim lngName As Long
    strExtension = Replace(strExtension, Chr(46), "")
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    'If the filename exists, add or increment a number to the filename
    'and keep checking until a unique name is found
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    'Reassemble the filename
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Public Function FileExists(strFullName As String) As Boolean
'Graham Mayor - http://www.gmayor.com
'strFullName is the name with path of the file to check
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(strFullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote