Give this a go:
Code:
Sub PrintToPDF_Worksheets_And_OLEObjects()
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: Print to PDF file using PDFCreator
' (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 sSheetsToPrint As String
Dim sSheets() As String
Dim lSheet As Long
Dim lTtlSheets As Long
Dim bRestart As Boolean
Dim lOLECount As Long
Dim wsOLE As Worksheet
Dim wordApp As Object
'/// Change the output file name here! ///
sPDFName = "Consolidated.pdf"
sPDFPath = ActiveWorkbook.Path & Application.PathSeparator
'/// Record the sheets you want to print here! ///
'/// Use sheet names separated by commas only ///
sSheetsToPrint = "Cover Page,Items Impacted,Approved,Change List"
Set wsOLE = Worksheets("Change List")
'Activate error handling and turn off screen updates
On Error GoTo EarlyExit
Application.ScreenUpdating = False
Set pdfjob = New PDFCreator.clsPDFCreator
'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
'Split the sheets into an array
sSheets() = Split(sSheetsToPrint, ",")
'Delete the PDF if it already exists
If Dir(sPDFPath & sPDFName) = sPDFName Then Kill (sPDFPath & sPDFName)
'Print the document to PDF
For lSheet = LBound(sSheets) To UBound(sSheets)
On Error Resume Next 'To deal with chart sheets
If Not IsEmpty(Application.Sheets(sSheets(lSheet)).UsedRange) Then
Application.Sheets(sSheets(lSheet)).PrintOut copies:=1, ActivePrinter:="PDFCreator"
lTtlSheets = lTtlSheets + 1
End If
On Error GoTo EarlyExit
Next lSheet
'Wait until all print jobs have entered the print queue
Do Until pdfjob.cCountOfPrintjobs = lTtlSheets
DoEvents
Loop
'Get OLE Objects too
If wsOLE.OLEObjects.Count > 0 Then
On Error Resume Next
Set wordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'Could not get instance, so create a new one
Err.Clear
On Error GoTo EarlyExit
Set wordApp = CreateObject("Word.Application")
With wordApp
.Visible = True
'.Documents.Add
End With
Else
'Bound to instance, activate error handling
On Error GoTo EarlyExit
End If
wordApp.ActivePrinter = "PDFCreator"
For lOLECount = 1 To wsOLE.OLEObjects.Count
wsOLE.OLEObjects(lOLECount).Verb Verb:=xlPrimary
wordApp.activedocument.PrintOut '<<<PRINT PROCESS OLE DOCUMENT, SEND TO PDF COLLECTION
wordApp.activedocument.Close 0 'do not save changes
Next lOLECount
wordApp.Quit
End If
'Wait until all print jobs have entered the print queue
Do Until pdfjob.cCountOfPrintjobs = lTtlSheets + lOLECount - 1
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
Set pdfjob = Nothing
Set wordApp = Nothing
Shell "taskkill /f /im PDFCreator.exe", vbHide
On Error GoTo 0
Application.ScreenUpdating = True
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
File with code in place also attached.
PDF Creator 1.6.0 OLE objects
Reply With Quote
Originally Posted by Ken Puls
Bookmarks