Option Explicit
Public Sub Merge_All_School_PDFs3()
Dim PDFsTable As ListObject
Dim headerSheet As Worksheet
Dim PDFsFolder As String, inputPDFs As String, FinalMergedPDF As String
Dim i As Long, n As Long
Dim school As String
Dim numPages As Long
Dim command As String
Dim MergeNumber As Long, MergedPDF As String
Dim PDFsColl As Collection, PDFfile As Variant
Dim Wsh As Object 'WshShell
Const MAX_COMMAND_LENGTH = 3000
Set Wsh = CreateObject("WScript.Shell") 'New WshShell
Set PDFsTable = ActiveSheet.ListObjects(1)
'Add temporary sheet which will be exported to PDF for each school's 2-page header
Set headerSheet = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
With PDFsTable
PDFsFolder = Left(.DataBodyRange(1, 2).Value, InStrRev(.DataBodyRange(1, 2).Value, "\"))
FinalMergedPDF = PDFsFolder & "All Schools Merged.pdf"
'Delete all the intermediate output PDFs and final merged PDF
Wsh.Run "cmd /c DEL " & Q2(PDFsFolder & "MERGE_*.pdf"), 0, True
If Dir(FinalMergedPDF) <> vbNullString Then Kill FinalMergedPDF
'Create BLANK.pdf which is added to list of PDFs to be merged for input PDFs which have an odd number of pages
headerSheet.Range("A1").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFsFolder & "BLANK.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Create collection of PDFs to be merged
Set PDFsColl = New Collection
school = ""
For i = 1 To .DataBodyRange.Rows.Count
Debug.Print .DataBodyRange(i, 1).Value, .DataBodyRange(i, 2).Value, .DataBodyRange(i, 3).Value
If .DataBodyRange(i, 1).Value <> school Then
'School has changed - update header sheet and export it as PDF with 2 pages
school = .DataBodyRange(i, 1).Value
With headerSheet.Range("C25")
.Clear
.Value = school
.Font.Name = "Calibri"
.Font.Size = 72
.Font.Bold = True
End With
headerSheet.Range("A1:I60").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFsFolder & school & " HEADER.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Add school header PDF to collection of PDFs to be merged
PDFsColl.Add school & " HEADER.pdf"
End If
'Get number of pages in this PDF
numPages = GetNumPages2(.DataBodyRange(i, 2).Value)
'Add PDF file in column 2 the number of times specified in column 3 to collection of PDFs to be merged
For n = 1 To .DataBodyRange(i, 3).Value
PDFsColl.Add Mid(.DataBodyRange(i, 2).Value, InStrRev(.DataBodyRange(i, 2).Value, "\") + 1)
If numPages Mod 2 <> 0 Then
'This PDF file has an odd number of pages so add BLANK.pdf to collection of PDFs to be merged
PDFsColl.Add "BLANK.pdf"
End If
Next
Next
End With
'Loop through collection of PDFs, merging multiple PDFs up to the specified maximum command line length
MergeNumber = 1
MergedPDF = "MERGE_" & MergeNumber & ".pdf"
inputPDFs = ""
For Each PDFfile In PDFsColl
'Would adding this PDF fit maximum command length?
If Len("CD /D " & Q2(PDFsFolder) & " & PDFtk " & inputPDFs & Q2(PDFfile) & " " & "cat output " & Q2(MergedPDF)) < MAX_COMMAND_LENGTH Then
'Yes, so add it to list of input PDFs to be merged
inputPDFs = inputPDFs & Q2(PDFfile) & " "
Else
'No, so merge input PDFs to the current intermediate merged output PDF
command = "CD /D " & Q2(PDFsFolder) & " & PDFtk " & inputPDFs & "cat output " & Q2(MergedPDF)
Debug.Print command
Wsh.Run "cmd /c " & command, 0, True
'Add the current intermediate merged output PDF and this PDF to the next set of PDFs to be merged
inputPDFs = Q2(MergedPDF) & " " & Q2(PDFfile) & " "
MergeNumber = MergeNumber + 1
MergedPDF = "MERGE_" & MergeNumber & ".pdf"
End If
Next
'Merge remaining input PDFs to the current intermediate merged output PDF
If inputPDFs <> "" Then
command = "CD /D " & Q2(PDFsFolder) & " & PDFtk " & inputPDFs & "cat output " & Q2(MergedPDF)
Debug.Print command
Wsh.Run "cmd /c " & command, 0, True
End If
'Copy the last intermediate merged output PDF to the final merged PDF
FileCopy PDFsFolder & MergedPDF, FinalMergedPDF
Application.DisplayAlerts = False
headerSheet.Delete
Application.DisplayAlerts = True
'Delete all the intermediate output PDFs, school header PDFs and BLANK.pdf
Wsh.Run "cmd /c DEL " & Q2(PDFsFolder & "MERGE_*.pdf"), 0, True
Wsh.Run "cmd /c DEL " & Q2(PDFsFolder & "* HEADER.pdf"), 0, True
Wsh.Run "cmd /c DEL " & Q2(PDFsFolder & "BLANK.pdf"), 0, True
MsgBox "Created " & FinalMergedPDF, vbInformation
End Sub
Private Function Q2(text As Variant) As String
Q2 = Chr(34) & text & Chr(34)
End Function
'Using FileSystemObject to read dump_data.txt file
Private Function GetNumPages2(PDFfullName As String) As Long
Dim Wsh As Object 'WshShell
Dim FSO As Object 'Scripting.FileSystemObject
Dim ts As Object 'Scripting.TextStream
Dim dataFile As String
Dim command As String
Dim allText As String
'Run PDFtk dump_data command to get number of pages in this PDF
dataFile = Left(PDFfullName, InStrRev(PDFfullName, "\")) & "dump_data.txt"
command = "PDFtk " & Q2(PDFfullName) & " dump_data output " & Q2(dataFile)
Debug.Print command
Set Wsh = CreateObject("WScript.Shell") 'New WshShell
Wsh.Run "cmd /c " & command, 0, True
Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
Set ts = FSO.OpenTextFile(dataFile, 1)
allText = ts.ReadAll
ts.Close
FSO.DeleteFile dataFile
GetNumPages2 = Split(Split(allText, "NumberOfPages: ")(1), vbCrLf)(0)
Debug.Print GetNumPages2 & " pages"
End Function
