Excel VBAから指定フォルダのパワーポイントファイルを複数選択し、白黒PDF印刷を行うサンプルコード

以下は、Excel VBAから指定フォルダのパワーポイントファイルを複数選択し、白黒PDF印刷を行うサンプルコードです。事前にcubePDFのプリンターがインストールされていることが前提です。

Sub PrintPPTtoPDF()
    Dim PPTFolder As String
    Dim PPTFile As String
    Dim objPPT As PowerPoint.Application
    Dim objPres As PowerPoint.Presentation
    
    'ダイアログボックスでフォルダ選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "パワーポイントファイルのあるフォルダを選択してください"
        If .Show <> -1 Then Exit Sub
        PPTFolder = .SelectedItems(1) & "\"
    End With
    
    'PowerPointを起動
    Set objPPT = New PowerPoint.Application
    objPPT.Visible = True
    
    '指定フォルダ内のPowerPointファイルを取得
    PPTFile = Dir(PPTFolder & "*.ppt*")
    Do While PPTFile <> ""
        'PowerPointファイルを開く
        Set objPres = objPPT.Presentations.Open(PPTFolder & PPTFile)
        
        '印刷設定を変更して、白黒PDFで印刷
        With objPres.PrintOptions
            .OutputFileName = PPTFolder & Left(PPTFile, InStrRev(PPTFile, ".") - 1) & ".pdf"
            .PrintColorType = ppPrintBlackAndWhite
            .RangeType = ppPrintAll
            .NumberOfCopies = 1
            .Collate = msoTrue
            .FitToPage = msoTrue
            .FrameSlides = msoFalse
            .ActivePrinter = "cubePDF"
            .PrintInBackground = msoFalse
            .OutputType = ppPrintOutputPDF
        End With
        
        '印刷実行
        objPres.PrintOut
        
        'PowerPointファイルを閉じる
        objPres.Close
        
        '次のPowerPointファイルを取得
        PPTFile = Dir()
    Loop
    
    'PowerPointを終了
    objPPT.Quit
    
    'オブジェクトを解放
    Set objPres = Nothing
    Set objPPT = Nothing
End Sub

このコードでは、FileDialogを使用して指定フォルダを選択し、そのフォルダ内のPowerPointファイルを順番に開いて白黒PDFで印刷しています。印刷にはcubePDFプリンターを使用しています。印刷結果は、元のPowerPointファイルと同じ名前のPDFファイルとして、同じフォルダに保存されます。

excel vbaから指定フォルダのパワーポイントファイルを複数選択し、選択したファイルをcubepdfでマージした後、白黒pdf印刷を行うソースコードを教えてください

以下は、Excel VBAから指定フォルダのPowerPointファイルを複数選択し、選択したファイルをCubePDFでマージした後、白黒PDF印刷を行うサンプルコードです。事前にCubePDFがインストールされている必要があります。

Sub MergeAndPrintPowerPoints()
    'CubePDFの実行ファイルパス
    Const CubePDFPath As String = "C:\Program Files\DocuTrack\PDF-XChange Standard\pdfSaver6.exe"
    
    'パワーポイントファイルを格納するフォルダのパスを取得
    Dim pptFolder As String
    pptFolder = "C:\PowerPoints"
    
    'ファイル選択ダイアログを表示し、選択されたパワーポイントファイルのパスを配列で取得
    Dim pptFiles() As Variant
    pptFiles = Application.GetOpenFilename(FileFilter:="PowerPointファイル (*.pptx;*.ppt), *.pptx;*.ppt", _
                                            Title:="パワーポイントファイルを選択してください", _
                                            MultiSelect:=True, _
                                            InitialFileName:=pptFolder)
                                            
    'パワーポイントファイルをCubePDFでマージ
    Dim mergedPDF As String
    mergedPDF = Environ("TEMP") & "\mergedPDF.pdf"
    Dim file As Variant
    For Each file In pptFiles
        Dim cmd As String
        cmd = Chr(34) & CubePDFPath & Chr(34) & " /printjob /printer ""Microsoft Print to PDF"" /outfile """ & mergedPDF & """ """ & file & """"
        Shell cmd, vbHide
    Next
    
    'マージしたPDFを白黒で印刷
    Dim acrobatApp As Object
    Set acrobatApp = CreateObject("AcroExch.App")
    Dim acrobatPDDoc As Object
    Set acrobatPDDoc = CreateObject("AcroExch.PDDoc")
    acrobatPDDoc.Open mergedPDF
    
    Dim acrobatAVDoc As Object
    Set acrobatAVDoc = CreateObject("AcroExch.AVDoc")
    acrobatAVDoc.Open "", "Acrobat"
    acrobatAVDoc.BringToFront
    acrobatAVDoc.PrintPages 0, acrobatPDDoc.GetNumPages - 1, 1, 1, True
    acrobatAVDoc.Close True
    
    acrobatPDDoc.Close
    acrobatApp.Exit
End Sub

このコードでは、まずCubePDFの実行ファイルパスをCubePDFPathに指定し、パワーポイントファイルが格納されるフォルダのパスをpptFolderに指定しています。Application.GetOpenFilenameメソッドで、ファイル選択ダイアログを表示し、選択されたパワーポイントファイルのパスを配列で取得します。次に、取得したパワーポイントファイルを1つずつCubePDFで印刷し、