フォルダ内のWordファイルをPDFで出力する

Sub フォルダ内のWordファイルをPDFで出力する()

    Dim StartTime  As Date          '開始時間
    Dim EndTime  As Date            '終了時間
    
    Dim FSO As Object               'ファイルシステムオブジェクト
    Dim FolderPath As String        'ダイアログで指定されたフォルダパス
    Dim objFolder As Object         'フォルダオブジェクト
    Dim objFiles As Object          'ファイルオブジェクト
    Dim objF As Object              'ファイルオブジェクト用for文変数
    Dim FileCount As Long           '処理するファイル数
    Dim FilePaths()                 '処理するファイルパス（配列）
    Dim i As Long
    Dim docWord As Document         '開いたWordファイル
    
    Dim WSH As Variant              'WSH(Windows Scripting Host)
    Dim DefaultPath As String       'デスクトップパス
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WSH = CreateObject("WScript.Shell")
    
    Dim strOutputFolder As String   '出力先フォルダ
    Dim PdfOptimizeOption As Long   'PDF最適化オプション
    Dim MsgRtn As Long              'Msgboxの戻り値
        
    StartTime = Now()   '開始時間
    
    '--------------------------------------
    'フォルダと直下のファイルを取得
    '--------------------------------------
    'フォルダダイアログ
    DefaultPath = WSH.SpecialFolders("Desktop") & "\"   'デスクトップに指定
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = DefaultPath      'デフォルトフォルダをデスクトップにする
        If .Show = True Then
            FolderPath = .SelectedItems(1)
        End If
    End With
    'フォルダダイアログで「キャンセル」したので終了
    If FolderPath = "" Then Exit Sub
    'フォルダ取得
    Set objFolder = FSO.GetFolder(FolderPath)
    'ファイルが1つもない場合は終了
    If objFolder.Files.Count = 0 Then
        '終了メッセージ
        MsgBox "指定されたフォルダにはファイルが1つもないので、終了します。", _
            vbOKOnly + vbExclamation
        Exit Sub
    End If
    'ファイル取得
    Set objFiles = objFolder.Files
    
    '--------------------------------------
    'ファイルパスを取得
    '--------------------------------------
    '処理するファイル数の初期化
    FileCount = 0
    For Each objF In objFiles
        'Wordのファイルのみ処理
        If LCase(FSO.GetExtensionName(objF.Name)) = "doc" Or _
            LCase(FSO.GetExtensionName(objF.Name)) = "docx" Then
            'ファイルカウント
            FileCount = FileCount + 1
            'ファイルパスを取得するための動的配列を定
            If FileCount = 1 Then
                ReDim FilePaths(FileCount)
            Else
                ReDim Preserve FilePaths(FileCount)
            End If
            'ファイルパスを配列に格納
            FilePaths(FileCount) = objF
        End If
    Next objF
    
    '処理対象のファイルが1つもない場合は終了
    If FileCount = 0 Then
        '終了メッセージ
        MsgBox "指定されたフォルダには処理対象となるファイルが1つもないので、終了します。", _
                vbOKOnly + vbExclamation
        Exit Sub
    End If
    
    '--------------------------------------
    'PDFファイルの出力先フォルダを作成
    '--------------------------------------
    Do
        strOutputFolder = FolderPath & "\" & "pdf_" & Format(Now(), "yymmdd_hhmmss")
        'フォルダがなかったら
        If FSO.FolderExists(strOutputFolder) = False Then
            'フォルダ作成
            On Error Resume Next
            FSO.CreateFolder (strOutputFolder)
            On Error GoTo 0
            If Err.Number = 0 Then
                Exit Do
            Else
                MsgBox "出力用フォルダを作成できませんでした。終了します。" & _
                        vbCrLf & vbCrLf & _
                        Err.Number & " : " & Err.Description & vbCrLf & vbCrLf & _
                        "フォルダ名:" & strOutputFolder, _
                        vbOKOnly + vbExclamation
                Exit Sub
            End If
        End If
    Loop
    
    '--------------------------------------
    'PDF最適化オプション選択
    '--------------------------------------
    MsgRtn = MsgBox("PDF最適化オプションはデフォルトのままでいいですか？" & _
            vbCrLf & vbCrLf & _
            "はい（デフォルト）：標準(オンライン発行及び印刷）" & vbCrLf & _
            "いいえ　　　　　　：最小サイズ（オンライン発行）" & vbCrLf & vbCrLf & _
            "※よくわからない場合は「はい」を選んでください。", _
            vbYesNo + vbInformation)
    If MsgRtn = vbYes Then
        PdfOptimizeOption = wdExportOptimizeForPrint '標準(オンライン発行及び印刷）
    ElseIf MsgRtn = vbNo Then
        PdfOptimizeOption = wdExportOptimizeForOnScreen '最小サイズ（オンライン発行）
    End If

    
    '--------------------------------------
    'ファイルを開いて処理する
    '--------------------------------------
    For i = 1 To FileCount
        'ファイルを開く（読み取り専用）
        Documents.Open FilePaths(i), ReadOnly:=True
        Set docWord = ActiveDocument
        
        docWord.ExportAsFixedFormat OutputFileName:=strOutputFolder & "\" & FSO.GetBaseName(docWord.Name) & ".pdf", _
            ExportFormat:=wdExportFormatPDF, OptimizeFor:=PdfOptimizeOption
        'ファイルを閉じる
        docWord.Close SaveChanges:=wdDoNotSaveChanges
    Next i
    
    '--------------------------------------
    '終了
    '--------------------------------------
    '終了時間
    EndTime = Now()
    '終了メッセージ
    MsgBox "PDFを " & FileCount & " ファイル出力しました。" & vbCrLf & vbCrLf & _
           "出力先フォルダ：" & strOutputFolder & vbCrLf & _
            "処理時間： " & Format(EndTime - StartTime, "hh:mm:ss"), _
            vbOKOnly + vbInformation
    
    'オブジェクトクリア
    Set FSO = Nothing
    Set objFolder = Nothing
    Set objF = Nothing
    Set docWord = Nothing
    Set WSH = Nothing

End Sub