ExcelのVBAで複数WordファイルのPDF化

convertPDF.xlsm

  'グローバル変数
  Dim fileObject As Variant
  Dim k As Integer
  
  'FileSystemObjectオブジェクト
  Dim fso As Scripting.FileSystemObjec
  
'////////////main//////////////'  
Public Sub main()
    
    'pdfName「出力先フォルダ」 と　filePath
    Dim filePath As String
    Dim pdfName As String
    
    'FileSystemObjectオブジェクト生成
    Set fso = New Scripting.FileSystemObject
      
    Dim fileExtension As String
    Dim documentsPath As Variant
    Dim outputPath As String
    
    'Wordアプリケーションオブジェクト生成
    Set wordApplication = CreateObject("Word.Application")
    
    'PDFにするファイルとPDF出力先のパス
    documentsPathArray = getDocumentsPath()
    outputPath = getOutputPath()

    If Cells(5, 2).Value = "" Or Cells(7, 4).Value = "" Then 'PDF化したいファイルか出力先が選択されているか判断
    
        MsgBox "PDF化したいファイルか出力先が選択されていません"
    
    Else
    
        'ループで配列からファイルパスを読み込み、PDF化。これを繰り返す。
        For k = LBound(documentsPathArray) To (UBound(documentsPathArray) - 1)

            fileExtension = fso.GetExtensionName(documentsPathArray(k))
            
            If fileExtension = "doc" Or fileExtension = "docx" Then
            
                'PDF変換実行
                Call word2PDF(documentsPathArray, outputPath)
                
            End If
            
        Next k
        
        MsgBox "PDF化、完了！！"
    
    End If

End Sub

'////////////word2PDF//////////////'
Sub word2PDF(documentsPath As Variant, outputPath As String)
    
    'FileSystemObjectオブジェクトの生成
    Set fso = New Scripting.FileSystemObject
    
    Dim wordApplicaion As Word.Application
    Dim openDoc As Word.Document
    
    'Wordアプリケーションオブジェクト生成とその表示
    Set wordApplication = CreateObject("Word.Application")
    wordApplication.Visible = True
    
    'PDF化したいドキュメントのパス取得
    filePath = documentsPath(k)
    
    'pdfの出力先
    pdfName = outputPath & "\" & (fso.GetBaseName(filePath)) & ".pdf"
    
    '読み取り専用で開く
    Set openDoc = wordApplication.Documents.Open(fileName:=filePath, ReadOnly:=True)

    'ドキュメントをPDFへ
    openDoc.ExportAsFixedFormat _
        OutputFileName:=pdfName, _
        ExportFormat:=wdExportFormatPDF, _
        OpenAfterExport:=False, _
        OptimizeFor:=wdExportOptimizeForPrint, _
        Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, _
        KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateHeadingBookmarks, _
        DocStructureTags:=True, _
        BitmapMissingFonts:=True, _
        UseISO19005_1:=False

    '一旦開いたファイルを保存せず閉じる
    openDoc.Close SaveChanges:=False
    
    'wordを閉じる
    wordApplication.Visible = False
    Set wordApplication = Nothing

End Sub

'////////////writeOfficePath//////////////'
Sub writeOfficePath()
 
  Dim filePath As String
  Dim fileName As Variant
  Dim Count As Long
  
  Count = 5
  
  'ファイルの選択
  fileName = Application.GetOpenFilename(FileFilter:="word, *.doc? ; *.docx?", MultiSelect:=True)
  
  If IsArray(fileName) Then 'ファイルが選択された時
   
   '取得したファイル名とパスをセルに出力
   For Each fileObject In fileName
   
    Cells(Count, 2).Value = fileObject
    Count = Count + 1

   Next fileObject
   
  Else 'ファイルがなかった時
  
   MsgBox "No file!!"
   
  End If

End Sub

'////////////writeOutputFolder//////////////'
Sub writeOutputFolder()

  Dim dlg As FileDialog
  Dim fold_path As String

  'FileDialogオブジェクト生成
  Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

  ' キャンセルボタンクリック時にマクロを終了
  If dlg.Show = False Then Exit Sub

  ' フォルダーのフルパスを変数に格納
  fold_path = dlg.SelectedItems(1)
  
  '出力先フォルダ
  Cells(7, 4).Value = fold_path
 
End Sub

'////////////getOutputPath//////////////'
Function getOutputPath() As String
    
    'PDF出力先のパス取得
    getOutputPath = Cells(7, 4).Value
    
End Function

'////////////getDocumentsPath//////////////'
Function getDocumentsPath() As Variant

    '各ファイルのパスと名前を格納する配列
    Dim documentsArray() As String
    
    'ファイル名とパス名が記述された最後の行
    Dim lastRow As Integer
    
    'ファイル名とパス名が記述された最後の行のナンバーを取得
    lastRow = Cells(5, 2).End(xlDown).Row
    
    'ファイル数を配列の要素数に設定
    ReDim documentsArray(lastRow - 5 + 1)
    
    Dim i As Integer
    Dim index As Integer
    
    index = 0
    
    '各ファイル名とパスを配列に格納
    For i = 5 To lastRow
        documentsArray(index) = Cells(i, 2).Value
        index = index + 1
    Next i
    
    getDocumentsPath = documentsArray

End Function