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

PDFファイルに一括変換

あるフォルダ内のExcel、Word、及びPowerPointファイルをPDFファイルに一括変換するコードです。
コードを実行すると、フォルダ選択ダイアログが表示され、フォルダを選択すると、PDF化の処理が始まります。
ファイルのサイズ等によっては多少時間を要する場合があります。

サンプルコード

コードの貼り付け場所

Sub Convert_to_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") With objOffice.Documents.Open(Path) .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

指定したフォルダ内にPDFフォルダを新たに作成し、そのPDFフォルダ内にPDF化されたファイルが作成されていきます。

汎用コードのリクエストをいただきました。

リクエストコード 12022.2.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


リクエストコード 22021.5.15

「PDFファイルに一括変換で、Wordを見えるようにした状態でPDF化し閉じる」
最初のコードとほぼ同じですが、★のついている行を追加しました。

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


ページトップへ戻る

Excel 汎用コード



Word 汎用コード

Copyright(C) 2009- 坂江 保 All Rights Reserved.