VBAでリスト通りにPDF結合をする

PDFをリスト順に結合したい。
ありそうで意外となかったコードを作成しました。

' フォルダ選択ダイアログを使用してフォルダパスを取得
Sub CombinePDFsFromList()
Dim folderPath As String
Dim outputFileName As String  
Dim ws As Worksheet
Dim acrobatObjUnion As New Acrobat.AcroPDDoc
Dim acrobatObjInsert As New Acrobat.AcroPDDoc
Dim pdfID_Union As Long
Dim pdfID_Insert As Long
Dim UniPageNum As Long: UniPageNum = 0
Dim InsPageNum As Long
Dim i As Long
Dim fileName As String
Dim filePath As String

' フォルダ選択ダイアログを使用してフォルダパスを取得
folderPath = GetFolderPath()
If folderPath = "" Then
    MsgBox "フォルダが選択されませんでした。処理を中止します。", vbExclamation
    Exit Sub
End If

' フォルダパスの最後にバックスラッシュがない場合は追加
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

outputFileName = InputBox("結合後のPDFファイル名を入力してください：", "出力ファイル名入力")
If outputFileName = "" Then Exit Sub  ' キャンセルされた場合は終了
If Right(outputFileName, 4) <> ".pdf" Then outputFileName = outputFileName & ".pdf"

' ワークシートの設定（リストが含まれているシートを指定）
Set ws = ThisWorkbook.Sheets("Sheet1")

' 空のPDFファイルを作成
pdfID_Union = acrobatObjUnion.Create()

' リストに従ってPDFを結合
For i = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    fileName = ws.Cells(i, 1).Value
    
    ' ファイルをフォルダ内で検索
    filePath = FindFile(folderPath, fileName)
    
    If filePath <> "" Then
        ' PDFファイルを開く
        pdfID_Insert = acrobatObjInsert.Open(filePath)
        
        ' ページ数を取得
        InsPageNum = acrobatObjInsert.GetNumPages()
        
        ' PDFファイルを結合
        On Error Resume Next
        pdfID_Union = acrobatObjUnion.InsertPages(UniPageNum - 1, acrobatObjInsert, 0, InsPageNum, True)
        If Err.Number <> 0 Then
            MsgBox "エラーが発生しました: " & Err.Description & " (ファイル: " & fileName & ")", vbExclamation
            Err.Clear
        End If
        On Error GoTo 0
        
        ' 結合用に開いたPDFファイルを閉じる
        pdfID_Insert = acrobatObjInsert.Close()
        
        ' 結合ページ数に挿入したページ数を足す
        UniPageNum = UniPageNum + InsPageNum
    Else
        MsgBox "ファイルが見つかりません: " & fileName, vbExclamation
    End If
Next i

' 結合したPDFを保存し、ファイルを閉じる
pdfID_Union = acrobatObjUnion.Save(PDSaveFull, folderPath & outputFileName)
pdfID_Union = acrobatObjUnion.Close

' オブジェクトを解放
Set acrobatObjInsert = Nothing
Set acrobatObjUnion = Nothing

MsgBox "PDFの結合が完了しました。保存先: " & folderPath & outputFileName, vbInformation
End Sub

　

' フォルダ選択ダイアログを使用してフォルダパスを取得
Function GetFolderPath() As String
Dim folderDialog As FileDialog
Dim selectedFolder As String

' フォルダ選択ダイアログを作成
Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)

With folderDialog
    .Title = "PDFファイルを検索するフォルダを選択してください"
    .AllowMultiSelect = False
    
    ' ダイアログを表示し、フォルダが選択されたかチェック
    If .Show = -1 Then
        selectedFolder = .SelectedItems(1)
    Else
        selectedFolder = ""
    End If
End With

' 選択されたフォルダパスを返す
GetFolderPath = selectedFolder
End Function

　

Function FindFile(folderPath As String, fileName As String) As String
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim subFolder As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

' 現在のフォルダ内のファイルを検索
For Each file In folder.Files
    If LCase(file.Name) = LCase(fileName) Then
        FindFile = file.Path
        Exit Function
    End If
Next file

' サブフォルダを再帰的に検索
For Each subFolder In folder.SubFolders
    FindFile = FindFile(subFolder.Path, fileName)
    If FindFile <> "" Then Exit Function
Next subFolder

' ファイルが見つからない場合は空文字を返す
FindFile = ""
End Function