PrintToPDF_MultiWordDoc_to_SingleFile.bas

Sub PrintToPDF_MultiWordDoc_to_SingleFile()
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Print all open Word documents to PDF (static filename)
'
'   (Download from http://sourceforge.net/projects/pdfcreator/)
'   Designed for early bind, set reference to PDFCreator
    Dim pdfjob As PDFCreator.clsPDFCreator
    Dim sPDFName As String
    Dim sPDFPath As String
    Dim sPrinter As String
    Dim lPrintOrder As Long
    Dim lDocs As Long
    Dim bRestart As Boolean
    Dim bBkgrndPrnt As Boolean

    'Activate error handling, capture properties and set req'd settings
    On Error GoTo EarlyExit
    With Application
        sPrinter = CStr(.ActivePrinter)
        .ActivePrinter = "PDFCreator"
        bBkgrndPrnt = .Options.PrintBackground
        .Options.PrintBackground = False
        .ScreenUpdating = False
    End With

    '/// Change the output file name here! ///
    sPDFName = "Consolidated.pdf"
    sPDFPath = "C:\Temp\"

    'Check if PDFCreator is already running and attempt to kill the process if so
    Do
        bRestart = False
        Set pdfjob = New PDFCreator.clsPDFCreator
        If pdfjob.cStart("/NoProcessingAtStartup") = False Then
            'PDF Creator is already running.  Kill the existing process
            Shell "taskkill /f /im PDFCreator.exe", vbHide
            DoEvents
            Set pdfjob = Nothing
            bRestart = True
        End If
    Loop Until bRestart = False

    'Assign settings for PDF job
    With pdfjob
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sPDFPath
        .cOption("AutosaveFilename") = sPDFName
        .cOption("AutosaveFormat") = 0    ' 0 = PDF
        .cClearCache
    End With

    'Print documents to print queue in reverse order
    For lPrintOrder = Application.Documents.Count To 1 Step -1
        Application.Documents(lPrintOrder).PrintOut copies:=1
        lDocs = lDocs + 1
    Next lPrintOrder

    'Wait until all print jobs have entered the print queue
    Do Until pdfjob.cCountOfPrintjobs = lDocs
        DoEvents
    Loop

    'Combine all PDFs into a single file and stop the printer
    With pdfjob
        .cCombineAll
        .cPrinterStop = False
    End With

    'Wait until the file shows up before closing PDF Creator
    Do
        DoEvents
    Loop Until Dir(sPDFPath & sPDFName) = sPDFName

Cleanup:
    'Release objects and terminate PDFCreator
    pdfjob.cClose
    Set pdfjob = Nothing
    Shell "taskkill /f /im PDFCreator.exe", vbHide
    On Error GoTo 0

    'Reset all application settings to user's original settings
    With Application
        .ScreenUpdating = True
        .ActivePrinter = sPrinter
        .Options.PrintBackground = bBkgrndPrnt
    End With
    Exit Sub

EarlyExit:
    'Inform user of error, and go to cleanup section
    MsgBox "There was an error encountered.  PDFCreator has" & vbCrLf & _
           "has been terminated.  Please try again.", _
           vbCritical + vbOKOnly, "Error"
    Resume Cleanup
End Sub