LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@CodeWizard(CodeWizard)

Excel VBA パワーポイントファイルをPDF形式に書き出す

Last updated at Posted at 2025-02-14

はじめに

パワーポイントファイルをPDF形式に書き出しを行う

プロシジャーの説明

任意のフォルダ内のすべてのパワーポイントファイルをPDF形式へ保存します

サンプル１ 　※対象フォルダは１ケ

Sub ConvertPPTtoPDF()
    Dim folderPath As String
    Dim fileName As String
    Dim pptApp As Object
    Dim pptPresentation As Object
    
    ' フォルダのパスを指定
    folderPath = "C:\Your\Folder\Path\" ' ここに変換したいファイルがあるフォルダのパスを指定してください
    
    ' PowerPointアプリケーションを起動
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' フォルダ内のすべてのファイルをループ
    fileName = Dir(folderPath & "*.ppt*")
    Do While fileName <> ""
        ' PowerPointファイルを開く
        Set pptPresentation = pptApp.Presentations.Open(folderPath & fileName)
        
        ' PDF形式で保存
        pptPresentation.SaveAs folderPath & Replace(fileName, ".ppt", ".pdf"), 32 ' 32はPDF形式を示します
        
        ' プレゼンテーションを閉じる
        pptPresentation.Close
        
        ' 次のファイルへ
        fileName = Dir()
    Loop
    
    ' PowerPointアプリケーションを終了
    pptApp.Quit
    Set pptApp = Nothing
End Sub

サンプル２ ※複数のフォルダを処理

Sub ConvertMultipleFoldersPPTtoPDF()
    Dim folderPaths As Variant
    Dim i As Integer
    Dim folderPath As String
    Dim fileName As String
    Dim pptApp As Object
    Dim pptPresentation As Object

    ' 処理したいフォルダのパスを配列として定義
    folderPaths = Array("C:\Folder1\", "C:\Folder2\", "C:\Folder3\") ' ここにフォルダのパスを追加してください

    ' PowerPointアプリケーションを起動
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True

    ' 各フォルダをループ
    For i = LBound(folderPaths) To UBound(folderPaths)
        folderPath = folderPaths(i)
        
        ' フォルダ内のすべてのファイルをループ
        fileName = Dir(folderPath & "*.ppt*")
        Do While fileName <> ""
            ' PowerPointファイルを開く
            Set pptPresentation = pptApp.Presentations.Open(folderPath & fileName)
            
            ' PDF形式で保存
            pptPresentation.SaveAs folderPath & Replace(fileName, ".ppt", ".pdf"), 32 ' 32はPDF形式を示します
            
            ' プレゼンテーションを閉じる
            pptPresentation.Close
            
            ' 次のファイルへ
            fileName = Dir()
        Loop
    Next i

    ' PowerPointアプリケーションを終了
    pptApp.Quit
    Set pptApp = Nothing
End Sub

サンプル３ ※ファイルサイズを適正化

Sub ConvertPPTtoPDF()
    Dim folderPath As String
    Dim fileName As String
    Dim pptApp As Object
    Dim pptPresentation As Object
    
    ' フォルダのパスを指定
    folderPath = "C:\Your\Folder\Path\" ' ここに変換したいファイルがあるフォルダのパスを指定してください
    
    ' PowerPointアプリケーションを起動
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' フォルダ内のすべてのファイルをループ
    fileName = Dir(folderPath & "*.ppt*")
    Do While fileName <> ""
        ' PowerPointファイルを開く
        Set pptPresentation = pptApp.Presentations.Open(folderPath & fileName)
        
        ' PDF形式で保存する際のオプションを設定
        Dim pdfExportOptions As Object
        pptPresentation.ExportAsFixedFormat _
            Path:=folderPath & Replace(fileName, ".ppt", ".pdf"), _
            FixedFormatType:=2, _
            Intent:=1, _
            FrameSlides:=False, _
            HandoutOrder:=0, _
            OutputType:=1, _
            PrintHiddenSlides:=False, _
            PrintRange:=Nothing, _
            RangeType:=0, _
            IncludeDocProperties:=True, _
            KeepIRMSettings:=True, _
            DocStructureTags:=True, _
            BitmapMissingFonts:=False, _
            UseISO19005_1:=False, _
            sRGB:=False, _
            Compatibility:=False, _
            DPI:=150 ' ここで解像度を指定
        
        ' プレゼンテーションを閉じる
        pptPresentation.Close
        
        ' 次のファイルへ
        fileName = Dir()
    Loop
    
    ' PowerPointアプリケーションを終了
    pptApp.Quit
    Set pptApp = Nothing
End Sub

サンプル４ ※ファイルサイズを適正化とパワポの拡張子がPDFファイル名に入ってしまう改善

Sub ConvertPPTtoPDF()
    Dim folderPath As String
    Dim fileName As String
    Dim baseName As String
    Dim pptApp As Object
    Dim pptPresentation As Object
    
    ' フォルダのパスを指定
    folderPath = "C:\Your\Folder\Path\" ' ここに変換したいファイルがあるフォルダのパスを指定してください
    
    ' PowerPointアプリケーションを起動
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' フォルダ内のすべてのファイルをループ
    fileName = Dir(folderPath & "*.ppt*")
    Do While fileName <> ""
        ' PowerPointファイルを開く
        Set pptPresentation = pptApp.Presentations.Open(folderPath & fileName)
        
        ' 拡張子を除去したファイル名を取得
        baseName = Left(fileName, InStrRev(fileName, ".") - 1)
        
        ' PDF形式で保存する際のオプションを設定
        pptPresentation.ExportAsFixedFormat _
            Path:=folderPath & baseName & ".pdf", _
            FixedFormatType:=2, _
            Intent:=1, _
            FrameSlides:=False, _
            HandoutOrder:=0, _
            OutputType:=1, _
            PrintHiddenSlides:=False, _
            PrintRange:=Nothing, _
            RangeType:=0, _
            IncludeDocProperties:=True, _
            KeepIRMSettings:=True, _
            DocStructureTags:=True, _
            BitmapMissingFonts:=False, _
            UseISO19005_1:=False, _
            sRGB:=False, _
            Compatibility:=False, _
            DPI:=150 ' ここで解像度を指定
        
        ' プレゼンテーションを閉じる
        pptPresentation.Close
        
        ' 次のファイルへ
        fileName = Dir()
    Loop
    
    ' PowerPointアプリケーションを終了
    pptApp.Quit
    Set pptApp = Nothing
End Sub

サンプル５ ※サンプル４の進化版。ExportAsFixedFormatを使用せずにPowerPointの印刷機能を使用しPDFのサイズを最小化する

Sub ConvertPPTtoPDFUsingPrint()
    Dim folderPath As String
    Dim fileName As String
    Dim baseName As String
    Dim pptApp As Object
    Dim pptPresentation As Object
    
    On Error GoTo ErrorHandler ' エラーハンドリングを追加
    
    ' フォルダのパスを指定
    folderPath = "C:\Your\Folder\Path\" ' ここに変換したいファイルがあるフォルダのパスを指定してください
    
    ' PowerPointアプリケーションを起動
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = False ' アプリケーションの可視化を制御
    
    ' フォルダ内のすべてのファイルをループ
    fileName = Dir(folderPath & "*.ppt*")
    Do While fileName <> ""
        ' PowerPointファイルを開く
        Set pptPresentation = pptApp.Presentations.Open(folderPath & fileName)
        
        ' 拡張子を除去したファイル名を取得
        baseName = Left(fileName, InStrRev(fileName, ".") - 1)
        
        ' 印刷機能を使用してPDFに保存
        pptPresentation.PrintOptions.PrintInBackground = False
        pptPresentation.PrintOptions.OutputType = ppPrintOutputSlides ' スライドをPDFに変換
        pptPresentation.PrintOptions.RangeType = ppPrintAll
        pptPresentation.PrintOptions.FrameSlides = False ' スライドのフレームを含めない
        pptPresentation.PrintOptions.HandoutOrder = ppPrintHandoutVerticalFirst ' ハンドアウトの順序を設定
        pptPresentation.PrintOptions.PrintHiddenSlides = False ' 隠しスライドを印刷しない
        pptPresentation.PrintOptions.PrintColorType = ppPrintColor
        pptPresentation.PrintOptions.PrintQuality = ppPrintHigh
        pptPresentation.PrintOptions.PrintHiddenSlides = False
        pptPresentation.PrintOut _
            PrintToFile:=folderPath & baseName & ".pdf", _
            PrintRange:=Nothing, _
            PrintColor:=ppPrintColor, _
            FitToPagesWide:=1, _
            FitToPagesTall:=1
        
        ' プレゼンテーションを閉じる
        pptPresentation.Close
        
        ' 次のファイルへ
        fileName = Dir()
    Loop
    
    ' PowerPointアプリケーションを終了
    pptApp.Quit
    Set pptApp = Nothing
    On Error GoTo 0
    Exit Sub
    
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description
    If Not pptApp Is Nothing Then
        pptApp.Quit
        Set pptApp = Nothing
    End If
End Sub
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?