Save as PDF with bookmarks

Albus · #1 08-17-2016, 08:46 AM

Hello,

These are the requirements for my macro:
1. Save the current document in the same folder with the same document name, except it will end in .pdf.
2. The "create bookmarks from headers" option is enabled.
3. It will prompt me if there is a file with the current name already.

I have this code, which accomplishes 1 and 3, but how would I add to it so that "create bookmarks from headers" is always enabled:

Code:

    Sub Save_to_PDF()
    
      With Dialogs(wdDialogFileSaveAs)
            .Format = wdFormatPDF
            .Show
         End With
    
    End Sub

Thanks for your help!

gmayor · #2 08-18-2016, 09:26 PM

Use instead the following. You will have to supply the name and path (here - strDocName).

Code:

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

Albus · #3 08-18-2016, 09:33 PM

Quote:

Originally Posted by gmayor

Use instead the following. You will have to supply the name and path (here - strDocName).

Code:

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

Hey thanks for the reply. I don't have access to test but do you know if this will prompt me to choose if I want to overwrite a file that already exists with the same name?

gmayor · #4 08-19-2016, 09:00 PM

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

Albus · #5 08-20-2016, 05:57 AM

Quote:

Originally Posted by gmayor

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

Wow thanks so much for such a detailed response. Will test it out on Monday and see how she works.

Albus · #6 08-23-2016, 06:03 AM

Awesome, this is so close to what I need.

How would I change it slightly so that instead of a fixed path and doc name, instead it opens up the dialogue box to ask if I want to save the PDF in the current folder and also suggests the pdf document name to be the same as the original doc but ending in .pdf instead of .docx?

gmayor · #7 08-24-2016, 01:18 AM

You need another function to get the folder and some more code in the main macro

Code:

Option Explicit

Sub Macro1()
Dim strPath As String
Dim strDocname As String
Dim lngAsk As Long
    On Error Resume Next
    ActiveDocument.Save
    If Len(ActiveDocument.Path) = 0 Then
        MsgBox "You must save the file before using this macro!"
        GoTo lbl_Exit
    End If
    On Error GoTo 0
    strPath = ActiveDocument.Path & Chr(92)
    lngAsk = MsgBox("Do you wish to save the PDF in the same folder as the document?", vbYesNo)
    If lngAsk = vbNo Then
        strPath = BrowseForFolder("Select the folder to save the PDF")
    End If
    strDocname = ActiveDocument.Name
    strDocname = Left(strDocname, InStrRev(strDocname, Chr(46))) & "pdf"
    If FileExists(strPath & strDocname) Then
        lngAsk = MsgBox(strPath & strDocname & " already exists." & vbCr & _
                        "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
lbl_Exit:
    Exit Sub
End Sub

Private 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

Private 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

Private Function BrowseForFolder(Optional strTitle As String) As String
'Graham Mayor - http://www.gmayor.com
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
    On Error GoTo err_handler
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_handler:
        BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
    End With
lbl_Exit:
    Exit Function
err_handler:
    BrowseForFolder = vbNullString
    Resume lbl_Exit
End Function

Albus · #8 08-25-2016, 12:13 PM

That is perfect, thank you! I really appreciate you updating your answers after my additional questions also. Cheers

rpatchet · #9 01-13-2017, 10:42 AM

I love your macro, I have been trying to do this for years on a huge Word document. And it worked great the first three times I used it. But the next day, the ExportAsFixedFormat fails with a read-only error. Running attrib from cmd.exe shows only the archive attribute set.

If I use ActiveDocument.SaveAs FileFormat:=wdFormatPDF (which does not let me select the PDF parameters, so it is unacceptable), the command fails and the VBA error dialog simply states that the command failed.

If I test for the existence of the file and try to delete it, the delete command fails and the VBA error dialog shows a permissions error.

I rebooted the computer to ensure no process had it locked. The Word document, macro, and PDF all exist in the same user account. When I do a File > Save As > PDF, Word prompts me to overwrite and then successfully writes the PDF.

I also encountered an odd problem with this macro. If I import the macro into a macro-free file, .docx, and run the macro, it works fine. If I save the document as a macro-enabled file, .docm, and run the macro, it fails.

Even more interesting: I deleted the PDF from the directory before I ran the macro and I still received the error "Run-time error '-2147467259 (80004005)': This file is read-only." I have no clue what file it thinks is read-only.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Bookmarks	Schildkröte	Word VBA	8	06-28-2015 11:13 AM
Form updating Bookmarks - writes to the bookmarks multiple times	PeterPlys	Word VBA	13	01-14-2015 06:41 AM
Can't See Bookmarks	bobmayo	Word	21	06-04-2013 07:37 AM
When I try to save an existing word doc, save as pops up and will not save...	samanthab	Word	3	01-19-2013 06:27 AM
Macro VBA "Save as" with bookmarks in file name string	Dom37	Word VBA	2	10-31-2011 03:28 AM