excel vbaから指定フォルダのパワーポイントファイルを複数選択し、選択したファイルを白黒pdf印刷して、そのあとそれらのpdfファイルをcubepdfでマージする
以下は、指定したフォルダから選択されたパワーポイントファイルを白黒PDFで印刷し、それらのPDFファイルをcubepdfでマージするVBAコードの例です。事前にcubePDFをインストールしておく必要があります。
Sub MergePowerPointPDFs()
'必要に応じて、cubePDFのインストールフォルダを指定してください
Dim cubePDFPath As String
cubePDFPath = "C:\Program Files\DocuCom\PDFDriver\Bin\PDFDirect.exe"
Dim pptFilePaths() As Variant
pptFilePaths = Application.GetOpenFilename(FileFilter:="PowerPoint Files (*.pptx; *.ppt), *.pptx; *.ppt", MultiSelect:=True)
If Not IsArray(pptFilePaths) Then
MsgBox "No PowerPoint files selected."
Exit Sub
End If
Dim pdfFilePaths() As Variant
ReDim pdfFilePaths(LBound(pptFilePaths) To UBound(pptFilePaths))
Dim i As Long
For i = LBound(pptFilePaths) To UBound(pptFilePaths)
'PowerPointを起動して、白黒PDFで印刷
Dim pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = False
Dim pptPresentation As Object
Set pptPresentation = pptApp.Presentations.Open(pptFilePaths(i), WithWindow:=msoFalse)
pptPresentation.ExportAsFixedFormat OutputFileName:=Replace(pptFilePaths(i), ".ppt", ".pdf"), _
ExportFormat:=ppFixedFormatTypePDF, _
PrintRange:=ppPrintAll, _
RangeType:=ppPrintAll, _
PrintColor:=msoFalse
pptPresentation.Close
pptApp.Quit
pdfFilePaths(i) = Replace(pptFilePaths(i), ".ppt", ".pdf")
Next i
'cubePDFでPDFファイルをマージ
Dim cubePDFCmd As String
cubePDFCmd = """" & cubePDFPath & """ /Merge " & Join(pdfFilePaths, ",") & " /Output ""merged.pdf"""
Shell cubePDFCmd, vbHide
'不要なPDFファイルを削除
For i = LBound(pdfFilePaths) To UBound(pdfFilePaths)
Kill pdfFilePaths(i)
Next i
End Sub
このコードでは、まずApplication.GetOpenFilenameメソッドを使用して、ユーザーが選択した複数のPowerPointファイルを取得します。その後、各ファイルについてPowerPointを起動して、白黒PDFで印刷します。印刷されたPDFファイルのパスを取得し、それらのファイルをcubepdfでマージします。最後に、不要なPDFファイルを削除します。
白黒印刷かカラー印刷かを選択できるように、上記のソースコードを書き直してください。
以下は、白黒印刷かカラー印刷かを選択できるように、指定フォルダ内のパワーポイントファイルを複数選択し、選択したファイルを印刷して、そのあとそれらのPDFファイルをCubePDFでマージするExcel VBAのソースコードです。
Sub PrintAndMergePPTs()
Dim pptFile As Variant
Dim printColor As Integer
Dim printBW As Integer
'選択したフォルダのパスを取得する
Dim folderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Else
MsgBox "フォルダが選択されませんでした。", vbCritical, "エラー"
Exit Sub
End If
End With
'白黒印刷かカラー印刷かを選択する
printColor = MsgBox("カラー印刷で行いますか？", vbYesNo, "印刷方法の選択")
If printColor = vbNo Then
printBW = 1 '白黒印刷
Else
printBW = 0 'カラー印刷
End If
'選択したフォルダ内のPPTファイルを取得する
pptFile = Dir(folderPath & "*.ppt*")
'PPTファイルを開いて印刷する
While pptFile <> ""
Dim pptApp As PowerPoint.Application
Set pptApp = New PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Set pptPres = pptApp.Presentations.Open(folderPath & pptFile)
If printBW = 1 Then
'白黒印刷する
pptPres.PrintOptions.OutputType = ppPrintOutputGrayscale
Else
'カラー印刷する
pptPres.PrintOptions.OutputType = ppPrintOutputColor
End If
pptPres.PrintOut
pptPres.Close
pptApp.Quit
pptFile = Dir()
Wend
'PDFファイルをマージする
Dim pdfFiles As String
pdfFiles = Dir(folderPath & "*.pdf")
If pdfFiles = "" Then
MsgBox "PDFファイルが見つかりませんでした。", vbCritical, "エラー"
Exit Sub
End If
Dim cubePDF As Object
Set cubePDF = CreateObject("cubepdf.CoreAPI")
Dim merger As Object
Set merger = cubePDF.MergeFiles
merger.SetOutputFile (folderPath & "merged.pdf")
While pdfFiles <> ""
merger.AddFile (folderPath & pdfFiles)
pdfFiles = Dir()
Wend
merger.Merge
Set cubePDF = Nothing
Set merger = Nothing
End Sub
