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 PrintEmbeddedPDFs_03()
' ZVI:2013-08-01 http://www.mrexcel.com/forum/excel-questions/717204-need-print-embedded-pdfs-please-help.html
' ZVI:2014-05-14 Added subrotines for printing sheets and embedded PDFs
' ZVI:2014-06-28 Fixed the incorrect finding of last "%%EOF" in PDF with comments
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, p As Variant, obj As OLEObject
p = ActiveWorkbook.Path
' Check OleObjects presence
With ActiveSheet.OLEObjects
If .Count = 0 Then
MsgBox "Embedded PDF not found", vbExclamation, "Nothing to print"
Exit Sub
End If
End With
On Error GoTo exit_
' Print all PDFs embedded into the active sheet
For Each obj In ActiveSheet.OLEObjects
i = 0: hWnd = 0: Size = 0: Ptr = 0
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
' --> ZVI:2014-06-28
k = InStrB(i, a, StrConv("%%EOF", vbFromUnicode))
While k
j = k - i + 7
k = InStrB(k + 5, a, StrConv("%%EOF", vbFromUnicode))
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 & "\_printed_.pdf"
If Len(Dir(f)) Then Kill f
FN = FreeFile
Open f For Binary As #FN
Put #FN, , b
Close #FN
CreateObject("wscript.shell").Run "AcroRd32.exe /N /T """ & f & """", , True
Kill f
End If
Else
Application.CutCopyMode = False
End If
End If
Next
' Inform how many Embedded PDFs were printed
MsgBox "Amount of the printed PDFs: " & n, vbInformation, "PrintEmbeddedPDFs"
exit_:
If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End Sub
Sub PrintSheetsAndThenEmbeddedPdfs()
PrintSheets
PrintEmbeddedPdfs
End Sub
Sub PrintSheetsAndPdfs()
Dim sh As Worksheet, obj As OLEObject
For Each sh In Worksheets
With sh.UsedRange
If .Cells.Count > 1 Or Len(.Cells(1)) Then
sh.PrintOut
End If
End With
For Each obj In sh.OLEObjects
If obj.progID Like "Acro*.Document*" And obj.OLEType = 1 Then
sh.Activate
Call PrintEmbeddedPDFs_03
Exit For
End If
Next
Next
End Sub
Sub PrintSheets()
Dim sh As Worksheet
For Each sh In Worksheets
With sh.UsedRange
If .Cells.Count > 1 Or Len(.Cells(1)) Then
sh.PrintOut
End If
End With
Next
End Sub
Sub PrintEmbeddedPdfs()
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
sh.Activate
Call PrintEmbeddedPDFs_03
Exit For
End If
Next
Next
End Sub
