トップ　>　汎用コード　>　PDFファイルに一括変換

'------------------------------------------------------------
' 指定フォルダのExcel/Word/PowerPointをPDFとして一括出力処理
'------------------------------------------------------------
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'------------------------------------------------------------
Sub ConvertToPdf()
    'フォルダの選択
    Dim strFolderPath As String
     With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    'フォルダ内の全ファイルパス取得
    Dim colFilePath As Collection
    Set colFilePath = GetFilePath(strFolderPath)
    If colFilePath.Count = 0 Then Exit Sub 'ファイルパスがなければ終了
    
    '出力フォルダ名
    Dim strOutputFolderName As String
    strOutputFolderName = "PDF"
    
    '区切り文字取得
    Dim strPathSeparator As String
    strPathSeparator = Application.PathSeparator
    
    '出力フォルダ名の前に区切り文字追加
    strOutputFolderName = strPathSeparator & strOutputFolderName
    
    'PDF出力先フォルダ作成
    If Dir(strFolderPath & strOutputFolderName, vbDirectory) = "" Then 'フォルダ存在確認
        MkDir strFolderPath & strOutputFolderName 'PDF用フォルダ作成
    End If

    '対象ファイルをPDFとして出力
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim i           As Long
    Dim strFileName As String
    For i = 1 To colFilePath.Count
        If ThisWorkbook.Path <> colFilePath(i) Then
            'ファイルパスからファイル名取得
            strFileName = Dir(colFilePath(i))
            'ファイル名の前に区切り文字追加
            strFileName = strPathSeparator & strFileName
            Call OutputPdfMainProcessing(strFolderPath, strOutputFolderName, strFileName)
        End If
    Next
    Application.ScreenUpdating = True
    
    'マクロ実行ブックもPDF出力する場合は以下をコメントアウト
'    strFileName = ThisWorkbook.Name
'    If 0 < InStr(1, strFileName, ".") Then
'        strFileName = Left$(strFileName, InStrRev(strFileName, ".") - 1)
'    End If
'    ThisWorkbook.ExportAsFixedFormat _
'        Type:=xlTypePDF, _
'        FileName:=strFolderPath & strOutputFolderName & strPathSeparator & strFileName, _
'        OpenAfterPublish:=False
    On Error GoTo 0
End Sub

'------------------------------------------------------------
' 指定フォルダ内の全ファイルパス取得関数
'------------------------------------------------------------
'［引数］
'   FolderPath ：対象フォルダパス
'［戻り値］
'   Collectionオブジェクト　各要素にファイルパスが格納される
'------------------------------------------------------------
Function GetFilePath(ByVal FolderPath As String) As Collection
    Set GetFilePath = New Collection
    Dim c   As Long
    Dim FSO As Object
    Dim F   As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each F In FSO.GetFolder(FolderPath).Files
        c = c + 1
        GetFilePath.Add F.Path, CStr(c)
    Next
End Function

'--------------------------------------------------------------------
' Excel/Word/PowerPointのPDF出力メイン処理
'--------------------------------------------------------------------
'［引数］
'   FolderPath      ：対象フォルダパス
'   OutputFolderName：区切り文字 & 出力フォルダ名　【例】\PDF
'   FileName        ：区切り文字 & 対象ファイル名　【例】\sample.xlsx
'--------------------------------------------------------------------
Sub OutputPdfMainProcessing(ByVal FolderPath As String, _
                            ByVal OutputFolderName As String, _
                            ByVal FileName As String)
    '対象ファイルのパス
    Dim TargetFilePath As String
    TargetFilePath = FolderPath & FileName
    
    '対象ファイルのパスから拡張子名を取得
    Dim strExtensionName As String
    With CreateObject("Scripting.FileSystemObject")
        strExtensionName = .GetExtensionName(TargetFilePath)
    End With
    
    'PDF出力ファイルフルパス作成
    Dim OutputFullPath As String
    If 0 < InStrRev(FileName, ".") Then
        FileName = Left$(FileName, InStrRev(FileName, ".")) & "pdf"
    Else
        FileName = FileName & ".pdf"
    End If
    OutputFullPath = FolderPath & OutputFolderName & FileName

    'Excel/Word/PowerPointの場合はPDFファイルとして出力
    Dim objOffice As Object
    Select Case strExtensionName '拡張子名でファイルを判定
    Case "xls", "xlsx" 'Excel97-2003,Excel2007以降
        Set objOffice = Excel.Application
        With objOffice.Workbooks.Open(TargetFilePath)
            .ExportAsFixedFormat Type:=xlTypePDF, _
            FileName:=OutputFullPath, OpenAfterPublish:=False
            .Close
        End With
    Case "doc", "docx" 'Word97-2003,Word2007以降
        Set objOffice = CreateObject("Word.Application")
        With objOffice.Documents.Open(TargetFilePath)
            .ExportAsFixedFormat OutputFileName:=OutputFullPath, _
            ExportFormat:=17
            .Close
        End With
        objOffice.Quit
    Case "ppt", "pptx" 'PowerPoint97-2003,PowerPoint2007以降
        Set objOffice = CreateObject("PowerPoint.Application")
        With objOffice.Presentations.Open(TargetFilePath)
            .SaveAs FileName:=OutputFullPath, FileFormat:=32
            .Close
        End With
        objOffice.Quit
    End Select
End Sub

'-------------------------------------------------------------
' 指定フォルダのExcelをシート指定でPDF出力
'-------------------------------------------------------------
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'-------------------------------------------------------------
Sub OutputExcelSheetAsPDF()
    '出力するExcelシートの番号設定(左から数えたシートの番号)
    Const SheetIndex As Long = 1 'シートの指定はこの数値を変更

    'フォルダの選択
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    'フォルダ存在確認
    If Dir(strFolderPath & "\PDF", vbDirectory) = "" Then
        MkDir strFolderPath & "\PDF" 'PDF用フォルダ作成
    End If

    'フォルダ内の全ファイルパス取得
    Dim colFilePath As Collection
    Set colFilePath = GetFilePath(strFolderPath)
    If colFilePath.Count = 0 Then Exit Sub 'ファイルパスがなければ終了
    
    'Excelファイルの指定シートをPDFで出力
    Application.ScreenUpdating = False
    Dim i As Long
    For i = 1 To colFilePath.Count
        If ThisWorkbook.Path <> colFilePath(i) Then
            Call MainProcessToOutputSheetAsPDF(strFolderPath, colFilePath(i), SheetIndex)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

'------------------------------------------------------------
' 対象フォルダ内の全ファイルパス取得関数
'------------------------------------------------------------
'［引数］
'   FolderPath ：対象フォルダパス
'［戻り値］
'   Collectionオブジェクト　各要素にファイルパスが格納される
'------------------------------------------------------------
Private Function GetFilePath(ByVal FolderPath As String) As Collection
    Set GetFilePath = New Collection
    Dim c   As Long
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim F   As Object
    For Each F In FSO.GetFolder(FolderPath).Files
        c = c + 1
        GetFilePath.Add F.Path, CStr(c)
    Next
End Function

'------------------------------------------------------------
' Excelファイルの指定シートをPDF出力するメイン処理
'------------------------------------------------------------
'［引数］
'   FolderPath：対象フォルダパス
'   FilePath  ：対象ファイルパス
'   SheetIndex：シート番号（ワークシートを左から数えた数値）
'------------------------------------------------------------
Private Sub MainProcessToOutputSheetAsPDF(ByVal FolderPath As String, _
                                          ByVal FilePath As String, _
                                          Optional SheetIndex As Long = 1)
    '拡張子を確認
    Dim strFileName As String
    With CreateObject("Scripting.FileSystemObject")
        Select Case .GetExtensionName(FilePath)
        Case "xls", "xlsx"
            strFileName = Dir(FilePath) 'ファイル名取得
        Case Else
            Exit Sub 'Excel標準ブック以外は抜ける
        End Select
    End With
    
    'PDFとして出力
    Dim strPDFFilePath As String
    strPDFFilePath = FolderPath & "\PDF\" & Left$(strFileName, InStrRev(strFileName, ".")) & "pdf"
    With Workbooks.Open(FilePath)
        If 0 < SheetIndex And SheetIndex <= .Worksheets.Count Then '該当シートの存在確認
            .Worksheets(SheetIndex).ExportAsFixedFormat _
                Type:=xlTypePDF, FileName:=strPDFFilePath, OpenAfterPublish:=False
        End If
        .Close
    End With
End Sub

'+++ 宣言セクション +++
Const PAGES      As Boolean = True  'ページ指定：True　文書全体：False
Const START_PAGE As Long = 1        '開始ページ
Const END_PAGE   As Long = 3        '終了ページ

Sub Convert_WordToPDF() 'ワードをPDF化　ページ指定対応コード
    Dim strDirPath As String
    With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダの選択
        If .Show = True Then strDirPath = .SelectedItems(1)
    End With
    If Len(strDirPath) = 0 Then Exit Sub
    If Dir(strDirPath & "\PDF", vbDirectory) = "" Then 'フォルダ存在確認
        MkDir strDirPath & "\PDF" 'フォルダ作成
    End If
    Call Search_Files(strDirPath)
End Sub

Private Sub Search_Files(ByVal Path As String)
    Dim strFile As String
    strFile = Dir(Path & "\" & "*.doc?") 'ファイル確認
    Application.ScreenUpdating = False
    Do Until strFile = ""
        If ThisWorkbook.FullName <> Path & "\" & strFile Then
            Call WordToPDF(Path, "\" & strFile)
        End If
        strFile = Dir() '次のファイル確認
    Loop
    Application.ScreenUpdating = True
End Sub

Private Sub WordToPDF(ByVal Path As String, ByVal Fn As String)
    Dim strFilePath  As String
    Dim objOffice    As Object
    strFilePath = Path & "\PDF" & Left$(Fn, InStrRev(Fn, ".")) & "pdf"
    Path = Path & Fn
    Select Case Get_Extension(Fn) 'ファイル名から拡張子取得
        Case "doc", "docx" 'Word97-2003,Word2007以降
            Set objOffice = CreateObject("Word.Application")
            With objOffice.Documents.Open(Path)
                If PAGES Then
                    .ExportAsFixedFormat OutputFileName:=strFilePath, _
                    ExportFormat:=17, Range:=3, From:=START_PAGE, To:=END_PAGE
                Else
                    .ExportAsFixedFormat OutputFileName:=strFilePath, _
                    ExportFormat:=17
                End If
                .Close
            End With
            objOffice.Quit
    End Select
End Sub

Private Function Get_Extension(ByVal Path As String) As String '拡張子取得
    Dim i As Long
    i = InStrRev(Path, ".", -1, vbTextCompare)
    If i = 0 Then Exit Function
    Get_Extension = Mid$(Path, i + 1)
End Function

Sub Convert_to_PDF() 'リクエストコード：Wordを見える状態でPDF化
    Dim strDirPath As String
    strDirPath = Search_Directory() 'フォルダの選択
    If Len(strDirPath) = 0 Then Exit Sub
    Call Make_Dir(strDirPath, "\PDF") 'フォルダ作成
    Call Search_Files(strDirPath)
End Sub

Private Function Search_Directory() As String 'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Private Sub Make_Dir(ByVal Path As String, ByVal Dn As String)
    If Dir(Path & Dn, vbDirectory) = "" Then 'フォルダ存在確認
        MkDir Path & Dn 'フォルダ作成
    End If
End Sub

Private Sub Search_Files(ByVal Path As String)
    Dim strFile As String
    strFile = Dir(Path & "\" & "*.*") 'ファイル確認
    Application.ScreenUpdating = False
    Do Until strFile = ""
        If ThisWorkbook.FullName <> Path & "\" & strFile Then
            Call Conv_PDF(Path, "\" & strFile)
        End If
        strFile = Dir() '次のファイル確認
    Loop
    Application.ScreenUpdating = True
End Sub

Private Function Get_Extension(ByVal Path As String) As String '拡張子取得
    Dim i As Long
    i = InStrRev(Path, ".", -1, vbTextCompare)
    If i = 0 Then Exit Function
    Get_Extension = Mid$(Path, i + 1)
End Function

Private Sub Conv_PDF(ByVal Path As String, ByVal Fn As String)
    Dim filePath  As String
    Dim objOffice As Object
    filePath = Path & "\PDF" & Left$(Fn, InStrRev(Fn, ".")) & "pdf"
    Path = Path & Fn
    Select Case Get_Extension(Fn) 'ファイル名から拡張子取得
        Case "xls", "xlsx" 'Excel97-2003,Excel2007以降
            Set objOffice = Excel.Application
            With objOffice.Workbooks.Open(Path)
                .ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=filePath, Openafterpublish:=False
                .Close
            End With
        Case "doc", "docx" 'Word97-2003,Word2007以降
            Set objOffice = CreateObject("Word.Application")
            objOffice.Visible = True '★
            With objOffice.Documents.Open(Path)
                Call AppActivate(.Windows(1).Caption & " - Word") 
                Application.Wait Now() + TimeValue("00:00:01")    
                .ExportAsFixedFormat OutputFileName:=filePath, _
                ExportFormat:=17
                .Close
            End With
            objOffice.Quit
        Case "ppt", "pptx" 'PowerPoint97-2003,PowerPoint2007以降
            Set objOffice = CreateObject("PowerPoint.Application")
            With objOffice.Presentations.Open(Path)
                .SaveAs Filename:=filePath, FileFormat:=32
                .Close
            End With
            objOffice.Quit
    End Select
End Sub