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

PDFファイルに一括変換2019.01.20 更新:2024.08.06

あるフォルダ内のExcel、Word、及びPowerPointファイルをPDFファイルに一括変換するコードです。
コードを実行すると、フォルダ選択ダイアログが表示され、フォルダを選択するとPDF化の処理が始まります(印刷対象がないファイルはPDF化はされません)
ファイルのサイズ等によっては多少時間を要する場合があります。
次の例のように、指定フォルダ内に同じファイル名が存在する場合、出力されるPDFファイルは上書きされますので気を付けてください。
【例】英語1.xlsx 英語1.docx


【お薦め】マクロ・プロシージャを管理する無料のツール!
 Excelマクロ管理ツール

サンプルコード2019.01.20 更新:2024.08.06

コードの貼り付け場所   VBAコードをカラーで印刷・Web掲載するためのツールはこちら

'------------------------------------------------------------
' 指定フォルダの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 False 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化されたファイルが作成されていきます。

書籍紹介本を執筆しました

好評販売中!
「教師のExcel ~校務(個人業務+チーム業務)カイゼンのためのデジタルリテラシー~」
基本の学びなおしから校務をサポートするシステム作りまで(技術評論社)

教員みんなができる「チーム業務」のポイントを丁寧にわかりやすく解説しています。また「個人業務」を更に効率化するための学び直しと応用テクニックを解説しています。
この書籍の活用してもらうことで、先生方が児童・生徒に向き合う時間を、更に確保できることを願っています!
■ 詳細(技術評論社)   ■ 内容紹介:note   ■ 購入:amazon

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

リクエスト 12023.10.20 更新:2024.08.06

「指定フォルダのExcelの全シートをシート名のPDFファイルとして出力
指定フォルダ内のExcelの全シートを、1シートずつPDFファイルとして出力するコードです。
マクロ「OutputAllExcelSheetsAsPDF」を実行しフォルダを選択すると処理が開始されます。
処理は、選択したフォルダ内のExcelを対象とします。Excelブック毎に、選択フォルダ内に新規フォルダが作成され、その作成されたフォルダ内にシート毎のPDFファイルが出力されます。PDFファイルのファイル名は出力対象となったシート名になります。
出力されるファイル名と同名のPDFファイルが既に存在した場合は、ファイルが上書きされますので気をつけてください。
また、Excelのファイル数やシート数が多い場合には、処理に時間を要しますので気をつけてください。

'-------------------------------------------------------------
' 指定フォルダのExcelの全シートをシート名のPDFファイルとして出力
'-------------------------------------------------------------
' ※ コード内でフォルダを選択しますが、そのフォルダの
'   書き込み権限がないとエラーになります
'   エラーが発生した場合にはPDFファイルは出力されません
'[掲載ページ]
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'-------------------------------------------------------------
Sub outputAllExcelSheetsAsPDF()
    'フォルダの選択
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    'フォルダ内の全Excelファイルパス取得
    Dim colFilePath As Collection
    Set colFilePath = getExcelFilePath(strFolderPath)
    If colFilePath.Count = 0 Then 'ファイルパスがなければ終了
        MsgBox "指定のフォルダにファイルが見つかりません", vbInformation
        Exit Sub
    End If
    
    'Excelファイルの全シートをPDFファイルとして出力
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim i As Long
    For i = 1 To colFilePath.Count
        If ThisWorkbook.Path <> colFilePath(i) Then
            Call outputSheetsAsPDF(strFolderPath, colFilePath(i))
        End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "終了しました"
    
    'フォルダを表示
    Shell "C:\Windows\Explorer.exe " & strFolderPath, vbNormalFocus
End Sub

'------------------------------------------------------------ ' 対象フォルダ内の全Excelファイルパス取得関数 '------------------------------------------------------------ ' 対象ファイルタイプ:xls/xlsx/xlsm/xlsb '[引数] ' FolderPath :対象フォルダパス '[戻り値] ' Collectionオブジェクト 各要素にファイルパスが格納される '[作成日]2023.10.19 [更新日]2023.12.20 ' https://excel.syogyoumujou.com/vba/conv_pdf.html '------------------------------------------------------------ Private Function getExcelFilePath(ByVal FolderPath As String) As Collection Set getExcelFilePath = New Collection Dim lngCount As Long Dim strFileName As String Dim strPathSeparator As String strPathSeparator = Application.PathSeparator strFileName = Dir(FolderPath & strPathSeparator & "*.xls?") Do Until strFileName = "" If ThisWorkbook.FullName <> FolderPath & strPathSeparator & strFileName Then lngCount = lngCount + 1 getExcelFilePath.Add FolderPath & strPathSeparator & strFileName, CStr(lngCount) End If strFileName = Dir() '次のファイル確認 Loop strFileName = Dir("") End Function
'------------------------------------------------------------ ' Excelファイルの全シートをそれぞれPDF出力するプロシージャ '------------------------------------------------------------ '[引数] ' FolderPath:Excelファイルが格納されているフォルダパス ' FilePath :対象のExcelファイルパス '------------------------------------------------------------ Private Sub outputSheetsAsPDF(ByVal FolderPath As String, _ ByVal FilePath As String) On Error Resume Next 'ファイル名取得 Dim strFileName As String strFileName = Dir(FilePath) 'フォルダ作成 FolderPath = FolderPath & "\" & Left$(strFileName, InStrRev(strFileName, ".") - 1) If Dir(FolderPath, vbDirectory) = "" Then MkDir FolderPath End If '各シートをPDFとして出力 Dim Sh As Worksheet Dim strPdfFilePath As String Dim strPdfFileName As String With Workbooks.Open(FilePath) For Each Sh In .Worksheets 'ファイル名禁止文字列をアンダーバー(_)に置換 strPdfFileName = replaceForbiddenCharactersFromFileName(Sh.Name, "_") 'シート名をファイル名とした出力ファイルパスの作成 strPdfFilePath = FolderPath & "\" & strPdfFileName & ".pdf" '対象シートをPDF出力 Sh.ExportAsFixedFormat _ Type:=xlTypePDF, FileName:=strPdfFilePath, OpenAfterPublish:=False Next .Close SaveChanges:=False End With On Error GoTo 0 End Sub
'-------------------------------------------------------- ' ファイル名禁止文字置換関数 '-------------------------------------------------------- '[引数] ' FileName :対象ファイル名の文字列 ' ReplaceSting:置換後文字列(既定:空の文字列) '[戻り値] ' ファイル名禁止文字を置換した文字列 '[作成日]2023/03/26 [更新日]2023/12/20 ' https://excel.syogyoumujou.com/vba/conv_pdf.html '-------------------------------------------------------- Private Function replaceForbiddenCharactersFromFileName(ByVal FileName As String, _ Optional ReplaceString As String = "") As String Dim varRemoveCharacters As Variant varRemoveCharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|") Dim i As Long For i = 0 To UBound(varRemoveCharacters) FileName = Replace$(FileName, varRemoveCharacters(i), ReplaceString, , , vbBinaryCompare) Next replaceForbiddenCharactersFromFileName = FileName End Function

リクエスト 22024.08.06

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 SaveChanges:=False End With End Sub

リクエスト 32023.12.23

「複数ページに及ぶ印刷範囲の任意のページ間を一つのPDFファイルとして出力」
指定シート内で印刷範囲が複数のページに及ぶ場合に、任意のページ~ページを指定して一つにまとめたPDFファイルとして出力するマクロです。PDFファイルの出力は仮想プリンターの「Microsoft Print To PDF」を利用します。
※「Microsoft Print to PDF」は、Windows10から標準でインストールされています

ページの指定は「開始ページ」から「終了ページ」となるため。離れたページをまとめることには対応していません。

'---------------------------------------------------------------------------------
' 【実行マクロ】指定シートの複数の印刷範囲を一つのPDFファイルとして出力する
'---------------------------------------------------------------------------------
' 出力先は既定でデスクトップにしています。
' 印刷に関する情報の変更は定数の値を変更してください。
' 出力ファイル名には自動で出力日時が追加されます。
'[作成日]2023.12.23 [更新日]2023.12.24
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'---------------------------------------------------------------------------------
Sub outputMultipleRangesAsOnePdfFile()
    '------------------------------------------------------------------------
    ' 定数
    '------------------------------------------------------------------------
    '【例】「伝票10%」シートの印刷範囲1~2ページを「サンプル*.pdf」として出力
    Const C_SHEETNAME    As String = "伝票10%"  '印刷対象シート名
    Const C_FROM         As Long = 1            '印刷開始ページ
    Const C_TO           As Long = 2            '印刷終了ページ
    Const C_PRTOFILENAME As String = "サンプル" '出力ファイル名

On Error Resume Next
    '------------------------------------------------------------------------
    ' 印刷シートの存在確認
    '------------------------------------------------------------------------
    Dim Sh As Worksheet
    Set Sh = ActiveWorkbook.Worksheets(C_SHEETNAME)
    If Sh Is Nothing Then
        MsgBox "印刷対象のシートが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If
On Error GoTo LBL_ERROR

    '------------------------------------------------------------------------
    ' 印刷範囲のページ数確認
    '------------------------------------------------------------------------
    Dim lngPages As Long
    lngPages = Sh.PageSetup.Pages.Count
   
    '------------------------------------------------------------------------
    ' 設定値確認
    '------------------------------------------------------------------------
    Dim strCheack As String
    If C_FROM < 1 Or lngPages < C_FROM Then
        strCheack = "印刷開始ページの設定が適切ではありません"
    ElseIf C_TO < 1 Or lngPages < C_TO Then
        strCheack = "印刷終了ページの設定が適切ではありません"
    End If
    If strCheack <> "" Then
        MsgBox strCheack, vbExclamation, "終了します"
        Exit Sub
    End If

    '------------------------------------------------------------------------
    ' デスクトップフォルダパス取得
    '------------------------------------------------------------------------
    Dim strFolderPath As String
    strFolderPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    '-----------------------------------------------------------------------
    ' フォルダ選択ダイアログ
    ' ※出力先フォルダを選択する場合は、次のコードをコメントアウトする
    '-----------------------------------------------------------------------
    'With Application.FileDialog(msoFileDialogFolderPicker)
    '    If .Show Then
    '        strFolderPath = .SelectedItems(1)
    '    Else
    '        Exit Sub
    '    End If
    'End With

    '---------------------------------------------------------------------
    ' フォルダパスに区切り文字を追加
    '---------------------------------------------------------------------
    strFolderPath = strFolderPath & Application.PathSeparator

    '---------------------------------------------------------------------
    ' 出力ファイル名作成
    '---------------------------------------------------------------------
    Dim strFileName As String
    strFileName = C_PRTOFILENAME & "_" & Format$(Now(), "yyyymmdd_HHMMSS") & ".pdf"

    'ファイル禁止文字の削除
    strFileName = replaceForbiddenCharactersFromFileName(strFileName)

    '---------------------------------------------------------------------
    ' 指定のシートを「Microsoft Print To PDF」で印刷する
    '---------------------------------------------------------------------
    If Not printoutMicrosoftToPdf(Sh, C_FROM, C_TO, strFolderPath & strFileName) Then
        Exit Sub 'エラーの場合は終了
    End If
                                
    MsgBox "PDFファイルを出力しました", vbInformation

    '---------------------------------------------------------------------
    ' ファイルを表示
    '---------------------------------------------------------------------
    Shell "C:\Windows\Explorer.exe " & strFolderPath & strFileName, vbNormalFocus
    Exit Sub
LBL_ERROR:
    MsgBox Err.Description, vbExclamation, "エラー番号:" & Err.Number
End Sub

'--------------------------------------------------------------------------------- ' 指定のシートを「Microsoft Print To PDF」で印刷する '--------------------------------------------------------------------------------- '[引数] ' Sh :印刷対象シート ' From :印刷を開始するページ番号を指定 ' To :印刷を終了するページ番号を指定 ' PrToFileName :引数 PrintTofile で True の場合に出力先ファイル名を指定 '[戻り値] ' 成功:True 失敗:Flase '[作成日]2023.12.23 [更新日]2023.12.24 ' https://excel.syogyoumujou.com/vba/conv_pdf.html '--------------------------------------------------------------------------------- Function printoutMicrosoftToPdf(ByRef Sh As Worksheet, _ Optional ByVal lngFrom As Long = 1, _ Optional ByVal lngTo As Long = 1, _ Optional ByVal PrToFileName As String = "") As Boolean On Error GoTo LBL_ERROR Call Sh.PrintOut(lngFrom, lngTo, 1, , "Microsoft Print to PDF", True, False, PrToFileName) printoutMicrosoftToPdf = True Exit Function LBL_ERROR: MsgBox Err.Description, vbExclamation, "エラー番号:" & Err.Number End Function
'--------------------------------------------------------------------------------- ' ファイル名禁止文字置換関数 '--------------------------------------------------------------------------------- '[引数] ' FileName :対象ファイル名の文字列 ' ReplaceSting:置換後文字列(既定:空の文字列) '[戻り値] ' ファイル名禁止文字を置換した文字列 '[作成日]2023/03/26 [更新日]2023/12/20 ' https://excel.syogyoumujou.com/vba/conv_pdf.html '--------------------------------------------------------------------------------- Function replaceForbiddenCharactersFromFileName(ByVal FileName As String, _ Optional ReplaceString As String = "") As String Dim varRemoveCharacters As Variant varRemoveCharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|") Dim i As Long For i = 0 To UBound(varRemoveCharacters) FileName = Replace$(FileName, varRemoveCharacters(i), ReplaceString, , , vbBinaryCompare) Next replaceForbiddenCharactersFromFileName = FileName End Function


リクエスト 42022.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

リクエスト 52021.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


ページトップへ戻る

Excel 汎用コード

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