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
