MS Word- build clean PDF & Export to meta-saved location for SharePoint

Attribute VB_Name = "DOC_EXPORT_PRINT" ' ===================================================================== ' File: Modules\PDFExportWithDiscard.bas ' ===================================================================== Option Explicit ' ===================================================================== ' Module-level constants ' ===================================================================== Private Const PROP_TARGET_COPY As String = "TargetCopyFolder" '' name of the custom document property to store the copy target path ' --------------------------------------------------------------------- ' Expected globals (documented only; not re-declared here): Public AutoDiscard As Long ' 0=off, 1=stop at first discard, >1=keep only non-discard Public FNCopyFileLocation As String ' Preferred copy folder for the resulting PDF ' ===================================================================== ' Main: Export active document to PDF with optional discard handling ' and copy to resolved target folder ' ===================================================================== Public Sub PDF_EXPORT() Dim doc As Document '' active document ref Dim pdfPath As String '' full output PDF path Dim toc As TableOfContents '' table of contents iterator Dim idx As Index '' index iterator Dim copyPath As String '' destination copy path Dim srcDate As Date '' source file timestamp Dim dstDate As Date '' destination file timestamp Dim wsh As WshShell '' WSH shell for launching file Dim targetPath As String '' resolved copy target folder Dim didExport As Boolean '' export success flag Dim defaultMode As Long '' optional external default mode Dim prompt As String '' discard prompt text Dim choice As VbMsgBoxResult '' discard choice Dim mode As Long '' 0=all, 1=to first discard, 2=non-discard only didExport = False '' initialize export flag Set wsh = New WshShell '' create WSH shell early-bound ' --- Resolve copy target path via stored property, or prompt, or Desktop fallback --- targetPath = ResolveTargetCopyFolder(ActiveDocument) '' try stored or ask user If LenB(targetPath) = 0 Then '' if user canceled dialog targetPath = GetDesktopPathWSH() '' fall back to Desktop End If '' end if targetPath FNCopyFileLocation = targetPath '' set global/Module var for later copy Set doc = ActiveDocument '' get active document pdfPath = doc.Path & "\" & Replace(doc.Name, ".docx", ".pdf") '' compute output PDF path ' --- Prepare document for clean PDF (hide revisions, update fields, update TOCs/Indexes) --- doc.ActiveWindow.View.ShowRevisionsAndComments = False '' hide revisions/comments doc.ActiveWindow.View.RevisionsView = wdRevisionsViewFinal '' show final view doc.Fields.Update '' update fields ' Update all TOCs For Each toc In doc.TablesOfContents '' iterate all TOCs toc.UpdatePageNumbers '' update page numbers Next '' next TOC ' Update all Indexes For Each idx In doc.Indexes '' iterate all Indexes idx.Update '' update index Next '' next index ' --- Ask user how to handle discard sections --- defaultMode = 0 '' initialize external default On Error Resume Next '' AutoDiscard may not exist If AutoDiscard <> 0 Then defaultMode = AutoDiscard '' if provided, use it On Error GoTo 0 '' restore normal error handling prompt = "Skip discard sections in print?" & vbCrLf & vbCrLf & _ "Yes = Stop at first discard (print pages before the first discard header)" & vbCrLf & _ "Cancel = Keep only non-discard sections (skip all discard blocks)" & vbCrLf & _ "No = Include all pages (ignore discard markers)" choice = MsgBox(prompt, vbYesNoCancel + vbQuestion, "Discard Sections") '' prompt user ' Map choice to mode Select Case choice '' evaluate user choice Case vbYes: mode = 1 '' stop at first discard Case vbCancel: mode = 2 '' keep only non-discard Case Else: mode = 0 '' include all pages End Select '' end Select Case ' If user chose "No" mode 0, export all If mode = 0 Then GoTo ExportAllFallback '' if mode=0 jump to full export On Error GoTo ExportAllFallback '' on any error fall back to full export If mode = 1 Then '' if exporting to first discard Dim firstDiscard As Long '' first discard page firstDiscard = CLng(GetPagesByDiscard(False)) '' compute first discard page If firstDiscard = 0 Then '' if no discard markers found GoTo ExportAllFallback '' fall back to full export ElseIf firstDiscard <= 1 Then '' else if discard at or before page 1 MsgBox "First discard is on page 1. Nothing to export before it.", vbInformation '' inform Exit Sub '' stop because nothing to export Else '' else have a positive page range '' export 1..firstDiscard-1 to PDF doc.ExportAsFixedFormat _ OutputFileName:=pdfPath, _ ExportFormat:=wdExportFormatPDF, _ OpenAfterExport:=False, _ OptimizeFor:=wdExportOptimizeForPrint, _ Range:=wdExportFromTo, _ From:=1, _ To:=firstDiscard - 1, _ Item:=wdExportDocumentContent, _ IncludeDocProps:=True, _ KeepIRM:=True, _ CreateBookmarks:=wdExportCreateHeadingBookmarks, _ DocStructureTags:=True, _ BitmapMissingFonts:=True, _ UseISO19005_1:=False didExport = True '' mark success End If '' end if firstDiscard ElseIf mode = 2 Then '' else if keeping only non-discard pages Dim keepPages As String '' pages list like "1-3,7-9" keepPages = CStr(GetPagesByDiscard(True)) '' compute include pages If Len(keepPages) > 0 Then '' if there are pages to keep '' print to PDF file Application.PrintOut _ Range:=wdPrintRangeOfPages, _ Item:=wdPrintDocumentContent, _ Pages:=keepPages, _ PrintToFile:=True, _ OutputFileName:=pdfPath, _ Background:=False didExport = True '' mark success Else '' else no keepable pages MsgBox "No pages outside discard sections.", vbInformation '' inform Exit Sub '' nothing to do End If '' end if keepPages End If '' end if mode ExportAllFallback: '' label: full-document export If Not didExport Then '' if earlier steps did not export err.CLEAR '' clear any errors '' export entire document doc.ExportAsFixedFormat _ OutputFileName:=pdfPath, _ ExportFormat:=wdExportFormatPDF, _ OpenAfterExport:=False, _ OptimizeFor:=wdExportOptimizeForPrint, _ Range:=wdExportAllDocument, _ Item:=wdExportDocumentContent, _ IncludeDocProps:=True, _ KeepIRM:=True, _ CreateBookmarks:=wdExportCreateHeadingBookmarks, _ DocStructureTags:=True, _ BitmapMissingFonts:=True, _ UseISO19005_1:=False End If '' end if didExport ' --- Copy to resolved location and verify timestamps --- If MsgBox("Copy exported PDF to reference folder?", vbYesNo + vbQuestion, "Copy PDF") = vbYes Then '' ask to copy copyPath = FNCopyFileLocation & "\" & Mid$(pdfPath, InStrRev(pdfPath, "\") + 1) '' build destination path On Error Resume Next '' tolerate transient copy errors FileCopy pdfPath, copyPath '' copy the file On Error GoTo 0 '' restore errors srcDate = FileDateTime(pdfPath) '' read source timestamp dstDate = FileDateTime(copyPath) '' read destination timestamp If Abs(DateDiff("s", srcDate, dstDate)) <= 1 Then '' if timestamps match within 1s MsgBox "PDF successfully copied to: " & copyPath, vbInformation '' confirm success Else '' else mismatch indicates failure MsgBox "Copy failed or timestamps differ. Please check manually.", vbExclamation '' warn Exit Sub '' stop further actions End If '' end if timestamp compare wsh.Run Chr$(34) & copyPath & Chr$(34), 1, False '' open copied PDF non-blocking Else '' else user declined copy MsgBox "Export complete: " & pdfPath, vbInformation '' notify export finished End If '' end if copy prompt Set wsh = Nothing '' release WSH shell End Sub ' ' Safe assumptions: ' - A "header" is any paragraph with OutlineLevel 1..9. ' - A discard marker is a header whose Style.NameLocal contains "(Discard". ' - The discard header page itself starts a block to skip. ' --------------------------------------------------------------------- ' --- Utility: join (from,to) pairs to "1-3,5,7-9" --- Private Function BuildPagesString(ByRef ranges As Collection) As String Dim sb As String, i As Long For i = 1 To ranges.count Dim pr As Variant: pr = ranges(i) ' (0)=from, (1)=to If pr(0) <= pr(1) Then If Len(sb) > 0 Then sb = sb & "," If pr(0) = pr(1) Then sb = sb & CStr(pr(0)) Else sb = sb & CStr(pr(0)) & "-" & CStr(pr(1)) End If End If Next BuildPagesString = sb End Function ' --------------------------------------------------------------------- ' Core API: ' GetPagesByDiscard(Optional ReturnFirstDiscard As Boolean = False) As Variant ' ' Returns: ' - If ReturnFirstDiscard = False (default): Long = first discard page (0 if none). ' - If ReturnFirstDiscard = True: String = keep page ranges "1-5,9-12". ' ' Why Variant: single entry point per your request; call-site chooses behavior by flag. ' --------------------------------------------------------------------- Public Function GetPagesByDiscard(Optional ByVal ReturnFirstDiscard As Boolean = False) As Variant Dim doc As Document: Set doc = ActiveDocument Dim totalPages As Long: totalPages = doc.Range.Information(wdNumberOfPagesInDocument) Dim starts() As Long, isDiscard() As Boolean, n As Long Dim lastPage As Long: lastPage = -1 Dim p As Paragraph, pg As Long, sty As String, isHdr As Boolean, isDisc As Boolean ' Collect unique heading starts per page For Each p In doc.Paragraphs isHdr = (p.OutlineLevel >= wdOutlineLevel1 And p.OutlineLevel <= wdOutlineLevel9) If isHdr Then pg = p.Range.Information(wdActiveEndPageNumber) If pg <> lastPage Then On Error Resume Next sty = p.Range.Style.nameLocal On Error GoTo 0 isDisc = (InStr(1, sty, "(Discard", vbTextCompare) > 0) n = n + 1 ReDim Preserve starts(1 To n) ReDim Preserve isDiscard(1 To n) starts(n) = pg isDiscard(n) = isDisc lastPage = pg End If End If Next ' No headings ? everything is keep If n = 0 Then If ReturnFirstDiscard = False Then GetPagesByDiscard = CLng(0) Else If totalPages > 0 Then GetPagesByDiscard = "1-" & CStr(totalPages) Else GetPagesByDiscard = "" End If End If Exit Function End If ' Append sentinel end n = n + 1 ReDim Preserve starts(1 To n) ReDim Preserve isDiscard(1 To n) starts(n) = totalPages + 1 isDiscard(n) = False Dim firstDiscard As Long: firstDiscard = 0 Dim keepRanges As New Collection Dim i As Long, segFrom As Long, segTo As Long For i = 1 To n - 1 segFrom = starts(i) segTo = starts(i + 1) - 1 If isDiscard(i) Then If firstDiscard = 0 Then firstDiscard = segFrom Else Dim pr(1) As Long pr(0) = segFrom pr(1) = segTo If pr(0) >= 1 And pr(1) <= totalPages And pr(0) <= pr(1) Then keepRanges.Add pr End If End If Next If ReturnFirstDiscard = False Then GetPagesByDiscard = CLng(firstDiscard) ' 0 if none Else GetPagesByDiscard = BuildPagesString(keepRanges) ' "" if nothing to keep End If End Function '------------------------------------------------------------------- ' Store target path info in meta information for copy over on run. ' --------------------------------------------------------------------- ' ===================================================================== ' Helper: Return current user's Desktop path using early-bound WSH ' ===================================================================== Public Function GetDesktopPathWSH() As String Dim wsh As WshShell '' WSH shell object Dim pth As String '' resolved Desktop path Set wsh = New WshShell '' create WSH shell pth = wsh.SpecialFolders("Desktop") '' get current user's Desktop If LenB(pth) > 0 Then '' if WSH returned a non-empty path GetDesktopPathWSH = pth '' return Desktop path Else '' else if empty GetDesktopPathWSH = Environ$("USERPROFILE") & "\Desktop" '' use environment fallback End If '' end if pth Set wsh = Nothing '' release COM End Function ' ===================================================================== ' Helpers: Read and write a string custom document property ' ===================================================================== Public Function GetCustomPropText(ByVal doc As Document, ByVal propName As String) As String Dim props As Office.DocumentProperties '' custom properties collection Dim p As Office.DocumentProperty '' one custom property Dim val As String '' return value Set props = doc.CustomDocumentProperties '' get custom properties On Error Resume Next '' property may not exist Set p = props.Item(propName) '' attempt to fetch property If err.Number = 0 Then '' if found val = CStr(p.value) '' read value as string Else '' else not found val = vbNullString '' return empty End If '' end if found On Error GoTo 0 '' clear error handling GetCustomPropText = val '' return value End Function Public Sub SetCustomPropText(ByVal doc As Document, ByVal propName As String, ByVal value As String) Dim props As Office.DocumentProperties '' custom properties collection Dim p As Office.DocumentProperty '' one property ref Set props = doc.CustomDocumentProperties '' get custom properties On Error Resume Next '' add or update may error Set p = props.Item(propName) '' try locate property If err.Number = 0 Then '' if exists p.value = value '' update value Else '' else missing err.CLEAR '' clear prior error '' add new string property props.Add Name:=propName, _ LinkToContent:=False, _ Type:=msoPropertyTypeString, _ value:=value End If '' end if exists On Error GoTo 0 '' restore errors End Sub ' ===================================================================== ' Helper: Folder picker dialog ' ===================================================================== Public Function PickFolderPath(ByVal titleText As String) As String Dim dlg As FileDialog '' folder picker dialog Dim pth As String '' selected path Set dlg = Application.FileDialog(msoFileDialogFolderPicker) '' init folder picker With dlg .Title = titleText '' set dialog title .AllowMultiSelect = False '' single selection only If .Show = -1 Then '' if user confirmed pth = .SelectedItems(1) '' take chosen path Else '' else user canceled pth = vbNullString '' return empty End If '' end if .Show End With PickFolderPath = pth '' return chosen path or empty Set dlg = Nothing '' release dialog End Function ' ===================================================================== ' Orchestrator: Resolve target folder ' 1) Use stored custom property if present ' 2) If missing, ask to store now (folder picker) and save it ' 3) If user declines, fall back to Desktop ' ===================================================================== Public Function ResolveTargetCopyFolder(ByVal doc As Document) As String Dim saved As String '' saved property value Dim msg As String '' message box text Dim ans As VbMsgBoxResult '' user choice Dim pick As String '' chosen folder saved = GetCustomPropText(doc, PROP_TARGET_COPY) '' read stored path If LenB(saved) > 0 Then '' if property already set ResolveTargetCopyFolder = saved '' use stored value Exit Function '' done End If '' end if saved msg = "No target copy folder is set for this document." & vbCrLf & vbCrLf & _ "Yes - pick a folder now and store it in the document." & vbCrLf & _ "No - do not store; use your Desktop for this export only." & vbCrLf & _ "Cancel - stop and do nothing." ans = MsgBox(msg, vbYesNoCancel + vbQuestion, "Set Target Copy Folder") '' ask user If ans = vbYes Then '' if user wants to set it pick = PickFolderPath("Choose and store the Target Copy Folder") '' pick folder If LenB(pick) > 0 Then '' if a folder was chosen SetCustomPropText doc, PROP_TARGET_COPY, pick '' save into doc property ResolveTargetCopyFolder = pick '' return chosen path Else '' else canceled picker ResolveTargetCopyFolder = GetDesktopPathWSH() '' use Desktop fallback End If '' end if pick ElseIf ans = vbNo Then '' else if user declined storing ResolveTargetCopyFolder = GetDesktopPathWSH() '' use Desktop for this run Else '' else Cancel ResolveTargetCopyFolder = vbNullString '' signal cancel to caller End If '' end if ans End Function