Need to Print Embedded PDFs

K

kmackie1

New Member
Joined
Jul 30, 2013
Messages
14
Here is my code so far:

Public Sub PrintPDFFiles()​
Const ADOBEPATH As String = "C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe"​
Const FILE_PATH As String = "C:\Users\kmackie\Desktop\Sample\Test"​
Const FILE_EXT As String = "PDF"​

​
Dim fso, fld, file​

​
Set fso = CreateObject("Scripting.FileSystemObject")​
Set fld = fso.GetFolder(FILE_PATH)​

​
For Each file In fld.Files​
If UCase(Right(file.Name, 3)) = FILE_EXT Then​
Shell """" & ADOBEPATH & """/n /t """ & file.Path & """"​
End If​
Next​
End Sub
​

This code works perfectly for what I am trying to do... except for one thing:

I want to open and print PDFs that are already embedded into my worksheet. I can use the code to open the embedded PDF files:


ActiveSheet.Shapes("Object 1").OLEFormat.Activate​

How on earth can I just open these files and print them. I've spent so long trying to figure this out. If you can't tell... I'm a bit of a newbie.

End result:
I want to be able to click a button, have it open the embedded pdf file in Adobe Reader, Print it, Close Adobe Reader.
I will name my first born son to the man that can solve this problem for me!
 
Sort by date Sort by votes
Re: Need to Print Embedded PDFs - PLEASE HELP :(

As the sub named PrintEmbeddedPDFs_04 is not compatible with Adobe Reader, but only Acrobat, adding code to time-delay to part of module PrintEmbeddedPDFs_03 appear to have fixed the issue.
 
Upvote 0

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Re: Need to Print Embedded PDFs - PLEASE HELP :(

saliman said:
As the sub named PrintEmbeddedPDFs_04 is not compatible with Adobe Reader, but only Acrobat, adding code to time-delay to part of module PrintEmbeddedPDFs_03 appear to have fixed the issue.
Click to expand...
the PrintEmbeddedPDFs_04 works great. But can it be let me select some of the embedded PDFs for printing instead of print all?
let say my PDFs are named A1-1, A1-2.. A2-1, A2-2, A3-1,....would be possible to let me select A1 then print all A1 document?
 
Upvote 0
Re: Need to Print Embedded PDFs - PLEASE HELP :(

carlrubber said:
the PrintEmbeddedPDFs_04 works great. But can it be let me select some of the embedded PDFs for printing instead of print all?
let say my PDFs are named A1-1, A1-2.. A2-1, A2-2, A3-1,....would be possible to let me select A1 then print all A1 document?
Click to expand...
PDF shed its file name being inserted into the sheet as OleObject.
Excel names the embedded objects as Object 1, Object 2 and so on.
You may see (a part of) a pathname on the inserted object shortcut’s picture only.
Use this code to list names of the embedded PDF objects:
Rich (BB code): 
Sub ListOlePDFs()
  Dim Sh As Worksheet, Obj As OLEObject
  For Each Sh In Worksheets
    For Each Obj In Sh.OLEObjects
      If Obj.progID Like "Acro*.Document*" And Obj.OLEType = 1 Then
        Debug.Print Sh.Name, Obj.Name
      End If
    Next
  Next
End Sub
To print the embedded objects renamed as A1-1, A1-2 ... by the mask A1-* run PrintOlePdfsByMask in the below code and enter that mask:
Rich (BB code): 
Option Explicit
 
#If VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  Dim hWnd As LongPtr, Size As LongPtr, Ptr As LongPtr
#Else
  Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function CloseClipboard Lib "user32" () As Long
  Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  Dim hWnd As Long, Size As Long, Ptr As Long
#End If
 
Sub PrintOlePdfsByMask()
  Const Title = "PrintOlePdfsByMask"
  Dim Sh As Worksheet, Obj As OLEObject
  Dim OlePDFs As New Collection
  Dim Mask  As String
  Mask = InputBox("Enter mask name of the embedded PDFs for printing", Title)
  If Len(Mask) = 0 Then Exit Sub
  For Each Sh In Worksheets
    If Sh.Visible Then
      For Each Obj In Sh.OLEObjects
        If Obj.progID Like "Acro*.Document*" And Obj.OLEType = 1 Then
          If UCase(Obj.Name) Like UCase(Mask) Then
            OlePDFs.Add Obj
          End If
        End If
      Next
    End If
  Next
  If OlePDFs.Count Then
    Call PrintOlePDFs(OlePDFs)
    MsgBox "Amount of the printed OlePDFs: " & OlePDFs.Count, vbInformation, Title
  Else
    MsgBox "No OlePDFs like '" & Mask & "' found", vbExclamation, Title
  End If
End Sub
 
 
Sub PrintOlePDFs(OlePDFs As Collection)
' ZVI:2017-03-16 https://www.mrexcel.com/forum/excel-questions/717204-need-print-embedded-pdfs-please-help-2.html#post4779734
  Dim a() As Byte, b() As Byte, i As Long, j As Long, k As Long, n As Long
  Dim FN As Integer, f As String, fname As String, p As String, s As String
  Dim AVDoc As Object, Obj As OLEObject
  p = Environ("TEMP")
  On Error GoTo exit_
  With CreateObject("AcroExch.App")
    Set AVDoc = CreateObject("AcroExch.AVDoc")
    For Each Obj In OlePDFs
      If Obj.progID Like "Acro*.Document*" And Obj.OLEType = 1 Then
        Obj.Copy
        If OpenClipboard(0) Then
          hWnd = GetClipboardData(49156)
          If hWnd Then Size = GlobalSize(hWnd)
          If Size Then Ptr = GlobalLock(hWnd)
          If Ptr Then
            ReDim a(1 To CLng(Size))
            CopyMemory a(1), ByVal Ptr, Size
            Call GlobalUnlock(hWnd)
            i = InStrB(a, StrConv("%PDF", vbFromUnicode))
            If i Then
              s = StrConv("%%EOF", vbFromUnicode)
              k = InStrB(i, a, s)
              While k
                j = k - i + 7
                k = InStrB(k + 5, a, s)
              Wend
              ReDim b(1 To j)
              For k = 1 To j
                b(k) = a(i + k - 1)
              Next
              Ptr = 0
            End If
          End If
          Application.CutCopyMode = False
          CloseClipboard
          If i Then
            n = n + 1
            f = p & "\" & n & "_embedded_.pdf"
            If Len(Dir(f)) Then Kill f
            FN = FreeFile
            Open f For Binary As #FN
            Put #FN, , b
            Close #FN
            With AVDoc
              .Open f, vbNullString
              .PrintPagesSilent 0, .GetPDDoc.GetNumPages - 1, 0, False, True
            End With
            .CloseAllDocs
            Kill f
          End If
        Else
          Application.CutCopyMode = False
        End If
      End If
    Next
    Set AVDoc = Nothing
    .Exit
  End With
exit_:
  If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End Sub
 
Last edited:
Upvote 0
Re: Need to Print Embedded PDFs - PLEASE HELP :(

Thanks for the excellent piece of code and replies so far. I'm a total noob in VBA doing all right with the rest of Excel. I can use a lot of your code but it just doesn't fit what I'm trying to achieve 100%. This is the case:

- I have about 10 worksheets that are used to define inputs and outputs for a proposal.
- There are about 5 sheets that need to be printed. the rest of the sheets are used to fill in information (thus cannot be hidden).
- One of the sheets contains an embedded multi page PDF (Terms & Conditions)
- The tricky part: The 5 sheets and the embedded PDF needs to be printed in 1 PDF document.

Can I achieve this using the code that is already in this threat?
How would I achieve this?

Oh and the end users of the proposal sheet are total noobs :) Help is much appreciated!
 
Upvote 0
Re: Need to Print Embedded PDFs - PLEASE HELP :(

Hi FP

You can't print all these separate instances as one PDF. It will extract as separate documents and then you can combine it with a program like Nuance PDF Create.

Maybe there is another option, but I'm not aware of it.
 
Upvote 0
Re: Need to Print Embedded PDFs - PLEASE HELP :(

FP1978 said:
...
- I have about 10 worksheets that are used to define inputs and outputs for a proposal.
- There are about 5 sheets that need to be printed. the rest of the sheets are used to fill in information (thus cannot be hidden).
- One of the sheets contains an embedded multi page PDF (Terms & Conditions)
- The tricky part: The 5 sheets and the embedded PDF needs to be printed in 1 PDF document...
Click to expand...

Hi,
The below code illustrates how to create PDF file with merging of some sheets and embedded PDF object.
Installing of Adobe Acrobat (Pro) is required for this code.
Rich (BB code): 
Option Explicit
 
#If  VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  Dim hWnd As LongPtr, Size As LongPtr, Ptr As LongPtr
#Else 
  Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function CloseClipboard Lib "user32" () As Long
  Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  Dim hWnd As Long, Size As Long, Ptr As Long
#End If
 
Sub Main()
 
  ' --> User settings, change to suit
  Const MergedPdf = "Merged_Document.pdf"                   ' Merged PDF file will be saved in folder of this workbook
  Const SheetsToPdf = "Sheet2,Sheet3,Sheet4,Sheet5,Sheet6"  ' List of sheets in the order of merging into PDF
  Const SheetWithEmbeddedPdf = "Sheet1"                     ' Sheet with embedded PDF
  Const EmbeddedPdf = 1                                     ' Index or "name" of the embedded PDF (for merging at the end)
  ' <-- End of settings
 
  Const PDF1 = "_1_.pdf", PDF2 = "_2_.pdf"
  Dim ActiveSh As Worksheet
  Dim TempPath As String, DestPathName As String
  Dim EmbeddedOlePdf As OLEObject
  ThisWorkbook.Activate
  Set EmbeddedOlePdf = Sheets(SheetWithEmbeddedPdf).OLEObjects(EmbeddedPdf)
  TempPath = Environ("TEMP") & ""
  DestPathName = ThisWorkbook.Path & "" & MergedPdf
  Set ActiveSh = ActiveSheet
 
  ' Delete PDF1 and PDF2 files if exist
  If Dir(TempPath & PDF1) <> "" Then Kill TempPath & PDF1
  If Dir(TempPath & PDF2) <> "" Then Kill TempPath & PDF2
 
  ' Save sheets to the temporary folder as PDF1
  Sheets(Split(SheetsToPdf, ",")).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                  FileName:=TempPath & PDF1, _
                                  Quality:=xlQualityStandard, _
                                  IncludeDocProperties:=True, _
                                  IgnorePrintAreas:=False, _
                                  OpenAfterPublish:=False
  ActiveSh.Select 
  
  ' Save the embedded PDF to the temporary folder as PDF2
  SaveOlePDF TempPath & PDF2, EmbeddedOlePdf
 
  ' Merge PDF2 & PDF2
  MergePDFs TempPath, PDF1 & "," & PDF2, DestPathName
 
  ' Delete PDF1 and PDF2 temporary files
  If Dir(TempPath & PDF1) <> "" Then Kill TempPath & PDF1
  If Dir(TempPath & PDF2) <> "" Then Kill TempPath & PDF2
 
End Sub
 
Sub SaveOlePDF(PathName As String, OlePDF As Object)
' ZVI:2018-04-22 - Saves embedded OlePdf object to the PathName file
  Dim a() As Byte, b() As Byte
  Dim i As Long, j As Long, k As Long
  Dim FN As Integer
  Dim s As String
  On Error GoTo exit_
  If OlePDF.progID Like "Acro*.Document*" And OlePDF.OLEType = 1 Then
    OlePDF.Copy
    If OpenClipboard(0) Then
      hWnd = GetClipboardData(49156)
      If hWnd Then Size = GlobalSize(hWnd)
      If Size Then Ptr = GlobalLock(hWnd)
      If Ptr Then
        ReDim a(1 To CLng(Size))
        CopyMemory a(1), ByVal Ptr, Size
        Call GlobalUnlock(hWnd)
        i = InStrB(a, StrConv("%PDF", vbFromUnicode))
        If i Then
          s = StrConv("%%EOF", vbFromUnicode)
          k = InStrB(i, a, s)
          While k
            j = k - i + 7
            k = InStrB(k + 5, a, s)
          Wend
          ReDim b(1 To j)
          For k = 1 To j
            b(k) = a(i + k - 1)
          Next
          Ptr = 0
        End If
      End If
      Application.CutCopyMode = False
      CloseClipboard
      If i Then
        If Len(Dir(PathName)) Then Kill PathName
        FN = FreeFile
        Open PathName For Binary As #FN 
        Put #FN , , b
        Close #FN 
      End If
    Else
      Application.CutCopyMode = False
    End If
  End If
exit_:
  If Err Then MsgBox Err.Description, vbCritical, "SaveOlePDF Error #" & Err.Number
End_Sub
 
Sub MergePDFs(SrcPath As String, SrcFiles As String, DestPathName As String)
' ZVI:2018-04-22 - Merge PDF files located in SrcPath folder and listed in SrcFile to the DestPathName PDF file
 
  Const PDSaveFull = 1
  Dim a As Variant, i As Long, j As Long, n As Long, m As Long, p As String
  Dim PartDocs(0 To 1) As Object
  Set PartDocs(0) = CreateObject("AcroExch.PDDoc")
  Set PartDocs(1) = CreateObject("AcroExch.PDDoc")
 
  If Right(SrcPath, 1) = "" Then p = SrcPath Else p = SrcPath & ""
  a = Split(SrcFiles, ",")
 
  On Error GoTo exit_
  If Len(Dir(DestPathName)) Then Kill DestPathName
  For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & Trim(a(i))) = "" Then
      MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "MergePDFs: Exit"
      GoTo exit_
    End If
    ' Open PDF document
    If i > 0 Then j = 1
    PartDocs(j).Open p & Trim(a(i))
    If i Then
      ' Merge PDF to the PartDocs(0) document
      m = PartDocs(1).GetNumPages()
      If Not PartDocs(0).InsertPages(n - 1, PartDocs(1), 0, m, True) Then
        MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "MergePDFs: Exit"
        GoTo exit_
      End If
      ' Calc the number of pages in the merged document
      n = n + m
      ' Release the memory
      PartDocs(1).Close
      Set PartDocs(1) = Nothing
    Else
      ' Calc the number of pages in the PartDocs(0) document
      n = PartDocs(0).GetNumPages()
    End If
  Next
 
  If i > UBound(a) Then
    ' Save the merged document to the DestPathName
    If Not PartDocs(0).Save(PDSaveFull, DestPathName) Then
      MsgBox "Cannot save merged PDF document:" & vbLf & DestPathName, vbExclamation, "MergePDFs: Exit"
    End If
  End If
 
exit_:
 
  ' Inform about error/success
  If Err Then
    MsgBox Err.Description, vbCritical, "MergePDFs: Error #" & Err.Number
  ElseIf i > UBound(a) Then
    MsgBox "Merged PDF file is created:" & vbLf & DestPathName, vbInformation, "MergePDFs: Done"
  End If
 
  ' Release the memory
  If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
  Set PartDocs(0) = Nothing
 
End Sub
How to implement the code:
1. Copy the below code by selecting and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor and return to Excel
8. To run the macro from Excel open the workbook and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name Main to Run it.
 
Last edited:
Upvote 0
Re: Need to Print Embedded PDFs - PLEASE HELP :(

That's Magic!!

The only downfall I have is that the end users not necessarily have Acrobat Pro on their computers. Am I correct that acrobat pro is only used for the merging of the PDF files?
The alternative I can try is to just insert the PDF pages as images and print that through the code. I'm curious about the quality though.

If anyone wishes to reuse the code, I made two changes for it to run as intended:

Code: 
Option Explicit
 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  Dim hWnd As LongPtr, Size As LongPtr, Ptr As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
  Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function CloseClipboard Lib "user32" () As Long
  Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  Dim hWnd As Long, Size As Long, Ptr As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Sub Main()
 
  ' --> User settings, change to suit
  Const MergedPdf = "Merged_Document.pdf"                   ' Merged PDF file will be saved in folder of this workbook
  Const SheetsToPdf = "Sheet2,Sheet3,Sheet4,Sheet5,Sheet6"  ' List of sheets in the order of merging into PDF
  Const SheetWithEmbeddedPdf = "Sheet1"                     ' Sheet with embedded PDF
  Const EmbeddedPdf = 1                                     ' Index or "name" of the embedded PDF (for merging at the end)
  ' <-- End of settings

 
  Const PDF1 = "_1_.pdf", PDF2 = "_2_.pdf"
  Dim ActiveSh As Worksheet
  Dim TempPath As String, DestPathName As String
  Dim EmbeddedOlePdf As OLEObject
  ThisWorkbook.Activate
  Set EmbeddedOlePdf = Sheets(SheetWithEmbeddedPdf).OLEObjects(EmbeddedPdf)
  TempPath = Environ("TEMP") & ""
  DestPathName = ThisWorkbook.Path & "" & MergedPdf
  Set ActiveSh = ActiveSheet
 
  ' Delete PDF1 and PDF2 files if exist
  If Dir(TempPath & PDF1) <> "" Then Kill TempPath & PDF1
  If Dir(TempPath & PDF2) <> "" Then Kill TempPath & PDF2
 
  ' Save sheets to the temporary folder as PDF1
  Sheets(Split(SheetsToPdf, ",")).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                  Filename:=TempPath & PDF1, _
                                  Quality:=xlQualityStandard, _
                                  IncludeDocProperties:=True, _
                                  IgnorePrintAreas:=False, _
                                  OpenAfterPublish:=False
  ActiveSh.Select
  
  ' Save the embedded PDF to the temporary folder as PDF2
  SaveOlePDF TempPath & PDF2, EmbeddedOlePdf
 
  ' Merge PDF2 & PDF2
  MergePDFs TempPath, PDF1 & "," & PDF2, DestPathName
 
  ' Delete PDF1 and PDF2 temporary files
  If Dir(TempPath & PDF1) <> "" Then Kill TempPath & PDF1
  If Dir(TempPath & PDF2) <> "" Then Kill TempPath & PDF2
 
End Sub
 
Sub SaveOlePDF(PathName As String, OlePDF As Object)
' ZVI:2018-04-22 - Saves embedded OlePdf object to the PathName file
  Dim a() As Byte, b() As Byte
  Dim i As Long, j As Long, k As Long
  Dim FN As Integer
  Dim s As String
  On Error GoTo exit_
  If OlePDF.progID Like "Acro*.Document*" And OlePDF.OLEType = 1 Then
    OlePDF.Copy
    If OpenClipboard(0) Then
      hWnd = GetClipboardData(49156)
      If hWnd Then Size = GlobalSize(hWnd)
      If Size Then Ptr = GlobalLock(hWnd)
      If Ptr Then
        ReDim a(1 To CLng(Size))
        CopyMemory a(1), ByVal Ptr, Size
        Call GlobalUnlock(hWnd)
        i = InStrB(a, StrConv("%PDF", vbFromUnicode))
        If i Then
          s = StrConv("%%EOF", vbFromUnicode)
          k = InStrB(i, a, s)
          While k
            j = k - i + 7
            k = InStrB(k + 5, a, s)
          Wend
          ReDim b(1 To j)
          For k = 1 To j
            b(k) = a(i + k - 1)
          Next
          Ptr = 0
        End If
      End If
      Application.CutCopyMode = False
      CloseClipboard
      If i Then
        If Len(Dir(PathName)) Then Kill PathName
        FN = FreeFile
        Open PathName For Binary As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FN]#FN[/URL] 
        Put [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FN]#FN[/URL] , , b
        Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FN]#FN[/URL] 
      End If
    Else
      Application.CutCopyMode = False
    End If
  End If
exit_:
  If Err Then MsgBox Err.Description, vbCritical, "SaveOlePDF Error #" & Err.Number
End Sub
 
Sub MergePDFs(SrcPath As String, SrcFiles As String, DestPathName As String)
' ZVI:2018-04-22 - Merge PDF files located in SrcPath folder and listed in SrcFile to the DestPathName PDF file
 
  Const PDSaveFull = 1
  Dim a As Variant, i As Long, j As Long, n As Long, m As Long, p As String
  Dim PartDocs(0 To 1) As Object
  Set PartDocs(0) = CreateObject("AcroExch.PDDoc")
  Set PartDocs(1) = CreateObject("AcroExch.PDDoc")
 
  If Right(SrcPath, 1) = "" Then p = SrcPath Else p = SrcPath & ""
  a = Split(SrcFiles, ",")
 
  On Error GoTo exit_
  If Len(Dir(DestPathName)) Then Kill DestPathName
  For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & Trim(a(i))) = "" Then
      MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "MergePDFs: Exit"
      GoTo exit_
    End If
    ' Open PDF document
    If i > 0 Then j = 1
    PartDocs(j).Open p & Trim(a(i))
    If i Then
      ' Merge PDF to the PartDocs(0) document
      m = PartDocs(1).GetNumPages()
      If Not PartDocs(0).InsertPages(n - 1, PartDocs(1), 0, m, True) Then
        MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "MergePDFs: Exit"
        GoTo exit_
      End If
      ' Calc the number of pages in the merged document
      n = n + m
      ' Release the memory
      PartDocs(1).Close
      Set PartDocs(1) = Nothing
    Else
      ' Calc the number of pages in the PartDocs(0) document
      n = PartDocs(0).GetNumPages()
    End If
  Next
 
  If i > UBound(a) Then
    ' Save the merged document to the DestPathName
    If Not PartDocs(0).Save(PDSaveFull, DestPathName) Then
      MsgBox "Cannot save merged PDF document:" & vbLf & DestPathName, vbExclamation, "MergePDFs: Exit"
    End If
  End If
 
exit_:
 
  ' Inform about error/success
  If Err Then
    MsgBox Err.Description, vbCritical, "MergePDFs: Error #" & Err.Number
  ElseIf i > UBound(a) Then
    MsgBox "Merged PDF file is created:" & vbLf & DestPathName, vbInformation, "MergePDFs: Done"
  End If
 
  ' Release the memory
  If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
  Set PartDocs(0) = Nothing
 
End Sub

Change 1: Sub SaveOlePDF closed properly (End_Sub -> End Sub)
Change 2: DestPathName: Added a \ to use the correct path of the excel sheet (DestPathName = ThisWorkbook.Path & "" & MergedPdf)
 
Upvote 0
Re: Need to Print Embedded PDFs - PLEASE HELP :(

FP1978 said:
That's Magic!!

The only downfall I have is that the end users not necessarily have Acrobat Pro on their computers. Am I correct that acrobat pro is only used for the merging of the PDF files?
The alternative I can try is to just insert the PDF pages as images and print that through the code. I'm curious about the quality though.

If anyone wishes to reuse the code, I made two changes for it to run as intended:

Change 1: Sub SaveOlePDF closed properly (End_Sub -> End Sub)
Change 2: DestPathName: Added a \ to use the correct path of the excel sheet (DestPathName = ThisWorkbook.Path & "" & MergedPdf)
Click to expand...
Glad it works for you as expected!
And yes, acrobat pro is only used for the merging of the PDF files.
Thank you for fixing the code, but engine of the forum still eats the quoted flash symbol even in your version.
Thus, this damaged line:
If Right(SrcPath, 1) = "" Then p = SrcPath Else p = SrcPath & ""
should be replaced, for example, by that one:
If Right(SrcPath, 1) = Application.PathSeparator Then p = SrcPath Else p = SrcPath & Application.PathSeparator

The updated code:
Rich (BB code): 
Option Explicit
 
#If  VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  Dim hWnd As LongPtr, Size As LongPtr, Ptr As LongPtr
#Else 
  Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function CloseClipboard Lib "user32" () As Long
  Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  Dim hWnd As Long, Size As Long, Ptr As Long
#End If
 
Sub Main()
 
  ' --> User settings, change to suit
  Const MergedPdf = "Merged_Document.pdf"                   ' Merged PDF file will be saved in folder of this workbook
  Const SheetsToPdf = "Sheet2,Sheet3,Sheet4,Sheet5,Sheet6"  ' List of sheets in the order of merging into PDF
  Const SheetWithEmbeddedPdf = "Sheet1"                     ' Sheet with embedded PDF
  Const EmbeddedPdf = 1                                     ' Index or "name" of the embedded PDF (for merging at the end)
  ' <-- End of settings
 
  Const PDF1 = "_1_.pdf", PDF2 = "_2_.pdf"
  Dim ActiveSh As Worksheet
  Dim TempPath As String, DestPathName As String
  Dim EmbeddedOlePdf As OLEObject
  ThisWorkbook.Activate
  Set EmbeddedOlePdf = Sheets(SheetWithEmbeddedPdf).OLEObjects(EmbeddedPdf)
  TempPath = Environ("TEMP") & ""
  DestPathName = ThisWorkbook.Path & "" & MergedPdf
  Set ActiveSh = ActiveSheet
 
  ' Delete PDF1 and PDF2 files if exist
  If Dir(TempPath & PDF1) <> "" Then Kill TempPath & PDF1
  If Dir(TempPath & PDF2) <> "" Then Kill TempPath & PDF2
 
  ' Save sheets to the temporary folder as PDF1
  Sheets(Split(SheetsToPdf, ",")).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                  FileName:=TempPath & PDF1, _
                                  Quality:=xlQualityStandard, _
                                  IncludeDocProperties:=True, _
                                  IgnorePrintAreas:=False, _
                                  OpenAfterPublish:=False
 
  ActiveSh.Select
  ' Save the embedded PDF to the temporary folder as PDF2
  SaveOlePDF TempPath & PDF2, EmbeddedOlePdf
 
  ' Merge PDF2 & PDF2
  MergePDFs TempPath, PDF1 & "," & PDF2, DestPathName
 
  ' Delete PDF1 and PDF2 temporary files
  If Dir(TempPath & PDF1) <> "" Then Kill TempPath & PDF1
  If Dir(TempPath & PDF2) <> "" Then Kill TempPath & PDF2
 
End Sub
 
Sub SaveOlePDF(PathName As String, OlePDF As Object)
' ZVI:2018-04-22 - Saves embedded OlePdf object to the PathName file
  Dim a() As Byte, b() As Byte
  Dim i As Long, j As Long, k As Long
  Dim FN As Integer
  Dim s As String
  On Error GoTo exit_
  If OlePDF.progID Like "Acro*.Document*" And OlePDF.OLEType = 1 Then
    OlePDF.Copy
    If OpenClipboard(0) Then
      hWnd = GetClipboardData(49156)
      If hWnd Then Size = GlobalSize(hWnd)
      If Size Then Ptr = GlobalLock(hWnd)
      If Ptr Then
        ReDim a(1 To CLng(Size))
        CopyMemory a(1), ByVal Ptr, Size
        Call GlobalUnlock(hWnd)
        i = InStrB(a, StrConv("%PDF", vbFromUnicode))
        If i Then
          s = StrConv("%%EOF", vbFromUnicode)
          k = InStrB(i, a, s)
          While k
            j = k - i + 7
            k = InStrB(k + 5, a, s)
          Wend
          ReDim b(1 To j)
          For k = 1 To j
            b(k) = a(i + k - 1)
          Next
          Ptr = 0
        End If
      End If
      Application.CutCopyMode = False
      CloseClipboard
      If i Then
        If Len(Dir(PathName)) Then Kill PathName
        FN = FreeFile
        Open PathName For Binary As #FN 
        Put #FN , , b
        Close #FN 
      End If
    Else
      Application.CutCopyMode = False
    End If
  End If
exit_:
  If Err Then MsgBox Err.Description, vbCritical, "SaveOlePDF Error #" & Err.Number
End Sub
 
Sub MergePDFs(SrcPath As String, SrcFiles As String, DestPathName As String)
' ZVI:2018-04-22 - Merge PDF files located in SrcPath folder and listed in SrcFile to the DestPathName PDF file
 
  Const PDSaveFull = 1
  Dim a As Variant, i As Long, j As Long, n As Long, m As Long, p As String
  Dim PartDocs(0 To 1) As Object
  Set PartDocs(0) = CreateObject("AcroExch.PDDoc")
  Set PartDocs(1) = CreateObject("AcroExch.PDDoc")
 
  If Right(SrcPath, 1) = Application.PathSeparator Then p = SrcPath Else p = SrcPath & Application.PathSeparator
  a = Split(SrcFiles, ",")
 
  On Error GoTo exit_
  If Len(Dir(DestPathName)) Then Kill DestPathName
  For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & Trim(a(i))) = "" Then
      MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "MergePDFs: Exit"
      GoTo exit_
    End If
    ' Open PDF document
    If i > 0 Then j = 1
    PartDocs(j).Open p & Trim(a(i))
    If i Then
      ' Merge PDF to the PartDocs(0) document
      m = PartDocs(1).GetNumPages()
      If Not PartDocs(0).InsertPages(n - 1, PartDocs(1), 0, m, True) Then
        MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "MergePDFs: Exit"
        GoTo exit_
      End If
      ' Calc the number of pages in the merged document
      n = n + m
      ' Release the memory
      PartDocs(1).Close
      Set PartDocs(1) = Nothing
    Else
      ' Calc the number of pages in the PartDocs(0) document
      n = PartDocs(0).GetNumPages()
    End If
  Next
 
  If i > UBound(a) Then
    ' Save the merged document to the DestPathName
    If Not PartDocs(0).Save(PDSaveFull, DestPathName) Then
      MsgBox "Cannot save merged PDF document:" & vbLf & DestPathName, vbExclamation, "MergePDFs: Exit"
    End If
  End If
 
exit_:
 
  ' Inform about error/success
  If Err Then
    MsgBox Err.Description, vbCritical, "MergePDFs: Error #" & Err.Number
  ElseIf i > UBound(a) Then
    MsgBox "Merged PDF file is created:" & vbLf & DestPathName, vbInformation, "MergePDFs: Done"
  End If
 
  ' Release the memory
  If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
  Set PartDocs(0) = Nothing
 
End Sub
 
Last edited:
Upvote 0
Good day ZVI, thank you again for all the macro. I have been trying to get the same macro to work using PDFSam (opensource) with absolute zero success. Wondering if there is any chance you might be able to help?

The aim is relatively similar to the original post. A form button (or shape button) to print/save active sheet + embedded PDFs, while merging them into 1 PDF (active sheet will be page 1, PDFs will be page 2 and onwards). The merged PDF is saved into the same folder as the worksheet. Any help will be sincerely appreciated.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Using VBA to retrieve specific pages from PDFs
Replies
1
Views
70
Big_Al_fae_the_rigs
B
O
  • Question Question
Convert a bulk of PDFs into different text files (same names)
Replies
0
Views
559
Oxirrinko
O
kelly mort
  • Solved
VBA Code to close an opened pdf amendment needed
2
Replies
11
Views
3K
mugginsjr
M
H
  • Question Question
Macro: Convert pdf into Excel and extract certain data to put together with file name
Replies
1
Views
3K
HeinrichPaul
H
R
  • Question Question
Paste Method Failed on PDF to Excel
Replies
2
Views
972
rex759
R

Forum statistics

Threads
1,223,666
Messages
6,173,673
Members
452,527
Latest member
ineedexcelhelptoday

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top