#1
|
|||
|
|||
Save as PDF with bookmarks
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 |
#2
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Quote:
|
#4
|
||||
|
||||
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 |
#5
|
|||
|
|||
Quote:
|
#6
|
|||
|
|||
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? |
#7
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#8
|
|||
|
|||
That is perfect, thank you! I really appreciate you updating your answers after my additional questions also. Cheers
|
#9
|
|||
|
|||
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 |