PDFファイルに一括変換
あるフォルダ内のExcel、Word、及びPowerPointファイルをPDFファイルに一括変換するコードです。
コードを実行すると、フォルダ選択ダイアログが表示され、フォルダを選択するとPDF化の処理が始まります(印刷対象がないファイルはPDF化はされません)
ファイルのサイズ等によっては多少時間を要する場合があります。
次の例のように、指定フォルダ内に同じファイル名が存在する場合、出力されるPDFファイルは上書きされますので気を付けてください。
【例】英語1.xlsx 英語1.docx
Excelマクロ管理ツール
サンプルコード2019.01/20 更新:2023.03.10
'------------------------------------------------------------ ' 指定フォルダの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
指定したフォルダ内にPDFフォルダを新たに作成し、そのPDFフォルダ内にPDF化されたファイルが作成されていきます。
汎用コードのリクエストをいただきました。
リクエストコード 12023.01.21
「Excelファイルをシート指定で一括PDF化」
指定フォルダ内のExcelの指定したシートをPDFとして出力します。対象のExcelファイルは「xlsx」または「xls」です。
マクロ「OutputExcelSheetAsPDF」を実行しフォルダを選択すると処理が開始されます。指定したフォルダ内にはPDFフォルダが作成され、そのフォルダにPDFファイルが出力されます。
シートの指定は、次のコードの赤字箇所の数値を変更します。数値は左から数えたワークシートの番号になります(一番左のワークシートは「1」)。
PDFフォルダに、出力されるファイル名と同名のPDFファイルが既に存在した場合は、ファイルが上書きされますので気をつけてください。
'------------------------------------------------------------- ' 指定フォルダの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
リクエストコード 22022.02.22
「Wordをページ指定で一括PDF化」
'+++ 宣言セクション +++ 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
リクエストコード 32021.05.15
「PDFファイルに一括変換で、Wordを見えるようにした状態でPDF化し閉じる」
★のついている行でWordを見える状態にしています。
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