Excel VBAを活用したPDFファイルの結合手順

Option Explicit

Private Const PDSaveFull As Long = 1
Private Const MAX_FILES As Long = 50
Private Const MAX_PAGES As Long = 2000
Private Const MAX_BYTES As Double = 524288000# ' 500 MiB

Public Sub ExecuteCombinePDFs()
    Dim pdfs As New Collection
    Dim resultPath As String
    On Error GoTo Failed

    ' Addした順に結合する。実在するローカルパスに変更する。
    pdfs.Add "C:\PDFwork\01_report.pdf"
    pdfs.Add "C:\PDFwork\02_appendix.pdf"
    resultPath = MergePdfFiles(pdfs, "C:\PDFwork\output")

    MsgBox "保存とページ数の確認が完了しました。" & vbCrLf & _
           resultPath & vbCrLf & "配布前にページ順と内容を確認してください。", vbInformation
    Exit Sub
Failed:
    MsgBox "処理を中止しました。" & vbCrLf & Err.Description, vbExclamation
End Sub

Public Function MergePdfFiles(ByVal pdfs As Collection, _
                              ByVal outputFolder As String) As String
    Dim fso As Object, seen As Object
    Dim dst As Object, src As Object, checkDoc As Object
    Dim dstOpen As Boolean, srcOpen As Boolean, checkOpen As Boolean
    Dim inputs() As String, copies() As String
    Dim ownedFiles As New Collection
    Dim jobFolder As String, pendingPath As String, finalPath As String
    Dim jobOwned As Boolean, saveAttempted As Boolean
    Dim p As String, item As Variant
    Dim i As Long, n As Long, totalPages As Long, countNow As Long
    Dim totalBytes As Double, errorNumber As Long, errorText As String

    On Error GoTo Failed
    If pdfs Is Nothing Then RaiseMergeError "入力リストがNothingです。"
    If pdfs.Count < 2 Or pdfs.Count > MAX_FILES Then
        RaiseMergeError "入力は2～50ファイルにしてください。"
    End If
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set seen = CreateObject("Scripting.Dictionary")
    seen.CompareMode = vbTextCompare
    outputFolder = LocalFullPath(outputFolder, fso)
    If Not fso.FolderExists(outputFolder) Then
        RaiseMergeError "出力先フォルダーがありません: " & outputFolder
    End If
    If Len(outputFolder) > 160 Then RaiseMergeError "出力先のパスが長すぎます。"
    ReDim inputs(1 To pdfs.Count)
    ReDim copies(1 To pdfs.Count)

    ' 全入力の基本条件を確認してから、コピーやAcrobat操作を始める。
    For i = 1 To pdfs.Count
        If VarType(pdfs(i)) <> vbString Then RaiseMergeError "入力は文字列で指定してください。"
        p = LocalFullPath(CStr(pdfs(i)), fso)
        If LCase$(fso.GetExtensionName(p)) <> "pdf" Then
            RaiseMergeError "PDF以外の拡張子です: " & p
        End If
        If Not fso.FileExists(p) Then RaiseMergeError "入力がありません: " & p
        If fso.GetFile(p).Size <= 0 Then RaiseMergeError "空ファイルです: " & p
        If seen.Exists(p) Then RaiseMergeError "入力パスが重複しています: " & p
        seen.Add p, True
        totalBytes = totalBytes + CDbl(fso.GetFile(p).Size)
        If totalBytes > MAX_BYTES Then RaiseMergeError "入力の合計が500 MiBを超えています。"
        inputs(i) = p
    Next i

    ' GetTempNameは名前を作るだけ。CreateFolderの成功後だけ所有を記録する。
    jobFolder = fso.BuildPath(outputFolder, "merge_" & fso.GetBaseName(fso.GetTempName))
    fso.CreateFolder jobFolder ' 既存ならエラー。既存フォルダーは使わない。
    jobOwned = True
    pendingPath = fso.BuildPath(jobFolder, "pending.pdf")
    finalPath = fso.BuildPath(jobFolder, "merged.pdf")

    ' 原本や、利用者がAcrobatで開いている原本のPDDocには触れない。
    For i = 1 To pdfs.Count
        copies(i) = fso.BuildPath(jobFolder, "input_" & Format$(i, "000") & ".pdf")
        ownedFiles.Add copies(i) ' コピー途中で失敗したファイルも後始末の対象。
        fso.CopyFile inputs(i), copies(i), False
    Next i

    Set dst = CreateObject("AcroExch.PDDoc")
    If dst.Open(copies(1)) = 0 Then RaiseMergeError "先頭のPDFを開けません: " & inputs(1)
    dstOpen = True
    totalPages = CLng(dst.GetNumPages())
    If totalPages < 1 Or totalPages > MAX_PAGES Then
        RaiseMergeError "先頭のPDFのページ数が対象範囲外です。"
    End If

    For i = 2 To pdfs.Count
        Set src = CreateObject("AcroExch.PDDoc")
        If src.Open(copies(i)) = 0 Then RaiseMergeError "PDFを開けません: " & inputs(i)
        srcOpen = True
        n = CLng(src.GetNumPages())
        If n < 1 Then RaiseMergeError "ページ数を取得できません: " & inputs(i)
        If n > MAX_PAGES - totalPages Then RaiseMergeError "合計ページ数が2000を超えます。"
        countNow = CLng(dst.GetNumPages())
        If countNow <> totalPages Then RaiseMergeError "結合先のページ数が不一致です。"

        ' 末尾の0始まり番号を指定。0は追加元のしおりをコピーしない指定。
        If dst.InsertPages(countNow - 1, src, 0, n, 0) = 0 Then
            RaiseMergeError "ページ追加に失敗しました: " & inputs(i)
        End If
        totalPages = totalPages + n
        If CLng(dst.GetNumPages()) <> totalPages Then
            RaiseMergeError "追加後のページ数が不一致です。"
        End If
        CloseOwnedDoc src, srcOpen
    Next i

    ' 全入力の追加成功後だけ保存。完成名ではなく検証用の名前に保存する。
    If fso.FileExists(pendingPath) Or fso.FolderExists(pendingPath) Or _
       fso.FileExists(finalPath) Or fso.FolderExists(finalPath) Then
        RaiseMergeError "作業フォルダー内に予期しない出力があります。"
    End If
    saveAttempted = True
    If dst.Save(PDSaveFull, pendingPath) = 0 Then RaiseMergeError "PDFの保存に失敗しました。"
    CloseOwnedDoc dst, dstOpen
    If Not fso.FileExists(pendingPath) Then RaiseMergeError "保存ファイルがありません。"
    If fso.GetFile(pendingPath).Size <= 0 Then RaiseMergeError "保存ファイルが空です。"

    Set checkDoc = CreateObject("AcroExch.PDDoc")
    If checkDoc.Open(pendingPath) = 0 Then RaiseMergeError "保存したPDFを再度開けません。"
    checkOpen = True
    If CLng(checkDoc.GetNumPages()) <> totalPages Then
        RaiseMergeError "保存後のページ数が不一致です。"
    End If
    CloseOwnedDoc checkDoc, checkOpen

    ' コピーを片付けてから完成名へ移動。MoveFileは既存ファイルを上書きしない。
    For Each item In ownedFiles
        fso.DeleteFile CStr(item), True
    Next item
    fso.MoveFile pendingPath, finalPath
    MergePdfFiles = finalPath
    Exit Function

Failed:
    errorNumber = Err.Number
    errorText = Err.Description
    ' エラー処理内のみ継続し、自分で開いた文書と作ったファイルだけを片付ける。
    On Error Resume Next
    CloseOwnedDoc checkDoc, checkOpen
    CloseOwnedDoc src, srcOpen
    CloseOwnedDoc dst, dstOpen
    If jobOwned Then
        For Each item In ownedFiles
            If fso.FileExists(CStr(item)) Then fso.DeleteFile CStr(item), True
        Next item
        If saveAttempted Then
            If fso.FileExists(pendingPath) Then fso.DeleteFile pendingPath, True
        End If
        RmDir jobFolder ' 空の場合だけ削除。フォルダーの再帰削除はしない。
        If fso.FolderExists(jobFolder) Then
            errorText = errorText & vbCrLf & "残存ファイルを確認してください: " & jobFolder
        End If
    End If
    Set checkDoc = Nothing
    Set src = Nothing
    Set dst = Nothing
    On Error GoTo 0
    If errorNumber = 0 Then errorNumber = vbObjectError + 2357
    Err.Raise errorNumber, "MergePdfFiles", errorText
End Function

Private Sub CloseOwnedDoc(ByRef doc As Object, ByRef isOpen As Boolean)
    If isOpen Then
        If doc.Close() = 0 Then RaiseMergeError "作業用PDFを閉じられませんでした。"
        isOpen = False
    End If
    Set doc = Nothing
End Sub

Private Sub RaiseMergeError(ByVal message As String)
    Err.Raise vbObjectError + 2357, "MergePdfFiles", message
End Sub

Private Function LocalFullPath(ByVal value As String, ByVal fso As Object) As String
    Dim i As Long, ch As String, result As String
    ' この例はドライブ文字付きのパスのみ。UNC、URL、相対パスは対象外。
    If Len(value) < 3 Then RaiseMergeError "絶対パスを指定してください。"
    If Not (UCase$(Left$(value, 1)) Like "[A-Z]") Then
        RaiseMergeError "ドライブ文字付きのパスを指定してください。"
    End If
    If Mid$(value, 2, 2) <> ":\" Then RaiseMergeError "絶対パスを指定してください。"
    For i = 3 To Len(value)
        ch = Mid$(value, i, 1)
        If AscW(ch) >= 0 And AscW(ch) < 32 Then RaiseMergeError "パスに制御文字があります。"
        If InStr(1, "*?""<>|:/", ch, vbBinaryCompare) > 0 Then
            RaiseMergeError "この例では扱えないパスです: " & value
        End If
    Next i
    result = fso.GetAbsolutePathName(value)
    If Len(result) > 240 Then RaiseMergeError "この例では240文字を超えるパスは扱いません。"
    LocalFullPath = result
End Function

"C:\Tools\PDFtk\bin\pdftk.exe" "C:\PDFwork\01_report.pdf" "C:\PDFwork\02_appendix.pdf" cat output "C:\PDFwork\new_combined.pdf"