#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_04(Optional Sh As Worksheet)
' 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
' ZVI:2014-07-11 Running of command line is replaced by automation of Acrobat application
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
If Sh Is Nothing Then Set Sh = ActiveSheet
p = Sh.Parent.Path
' Check OleObjects presence
With Sh.OLEObjects
If .Count = 0 Then
MsgBox "Embedded PDF not found", vbExclamation, "Nothing to print"
Exit Sub
End If
End With
On Error GoTo exit_
With CreateObject("AcroExch.App") ' <-- ZVI:2014-07-11
' Print all PDFs embedded into the active sheet
For Each obj In Sh.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)) ' - i + 7
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 & "\" & n & "_embedded_.pdf"
If Len(Dir(f)) Then Kill f
FN = FreeFile
Open f For Binary As #FN
Put #FN, , b
Close #FN
' --> ZVI:2014-07-11 Silent printing
With CreateObject("AcroExch.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
.Exit ' <-- ZVI:2014-07-11
End With ' <-- ZVI:2014-07-11
' Show the amount of embedded PDFs being 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
For Each Sh In Worksheets
If Sh.Visible Then
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
PrintEmbeddedPDFs_04 Sh
Exit For
End If
Next
End If
Next
End Sub
Sub PrintSheets()
Dim Sh As Worksheet
For Each Sh In Worksheets
If Sh.Visible Then
With Sh.UsedRange
If .Cells.Count > 1 Or Len(.Cells(1)) Then
Sh.PrintOut
End If
End With
End If
Next
End Sub
Sub PrintEmbeddedPdfs()
Dim Sh As Worksheet, obj As OLEObject
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
PrintEmbeddedPDFs_04 Sh
Exit For
End If
Next
End If
Next
End Sub
