PPT VBA：批量转PDF

目录

一、思路

1.获取文件列表

2.遍历文件列表中的文件

3.调用相应过程进生成PDF

4.完成

二、示例代码

三、补充

---

一、思路

1.获取文件列表

通过fso对象逐层获取主文件夹下的各层子文件夹，存入一个数组

然后遍历这个数组，获取每个文件夹下的PPT文件，存入另一个数组drr

2.遍历文件列表中的文件

遍历前面的drr，同时把拼接出导出的PDF文件的路径fName

用presentations.open()方法打开遍历的PPT文件，赋值给prs对象

3.调用相应过程进生成PDF

将打开的文件prs对象和PDF路径fName传递给另存、导出或打印的过程，生成PDF

4.完成

完成，关闭打开的DPF文件prs

二、示例代码

Rem 此处以下为主程序
Sub 批量获取文件路径()
    Dim fd As FileDialog
    Dim fso As Object
    Dim arr() '存储所有word文件路径
    Dim brr() '存储每次遍历到的文件夹的子文件夹
    Dim crr() '存储所有文件夹
    Dim drr() '存储所有Word文件路径
    Dim myFolder As Object
    Dim subFolder As Variant
    Dim i As Long
    Dim j As Long
    Dim m As Long
    Dim myFile As Object
    Dim 后缀 As String
    Dim t0 As Single
    Dim cType As Integer
    Dim fName As String
    Dim prs As Presentation
    t0 = Timer
    i = 0: j = 0: m = 0
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    Set fso = CreateObject("Scripting.FileSystemObject")

    With fd
        .Title = "选择主文件夹"
        If .Show Then
            i = i + 1
            ReDim Preserve crr(1 To i)
            crr(i) = .SelectedItems(1)
            arr = crr

            On Error Resume Next
            Do While Err.Number = 0
                For j = LBound(arr) To UBound(arr)
                    Set myFolder = fso.GetFolder(arr(j))
                    If myFolder.subFolders.Count > 0 Then
                        For Each subFolder In myFolder.subFolders
                            i = i + 1
                            ReDim Preserve crr(1 To i)
                            crr(i) = subFolder.Path

                            m = m + 1
                            ReDim Preserve brr(1 To m)
                            brr(m) = subFolder.Path
                        Next
                    End If
                Next
                m = 0
                arr = brr
                Erase brr
            Loop
            On Error GoTo 0

            i = 0
            For j = LBound(crr) To UBound(crr)
'                Debug.Print j, crr(j)
                Set myFolder = fso.GetFolder(crr(j))
                For Each myFile In myFolder.Files
                    后缀 = fso.GetExtensionName(myFile.Path)
                    If 后缀 Like "ppt*" And Not myFile.Path Like "*~$*" Then
                        i = i + 1
                        ReDim Preserve drr(1 To i)
                        drr(i) = myFile.Path
                    End If
                Next
            Next

            cType = Int(Trim(InputBox("请输入生成PDF的方式：" & vbCrLf & "1：另存" & vbCrLf & "2：导出" & vbCrLf & "3：打印", "方式选择", 2)))
            Do While cType < 1 Or cType > 3
                cType = Int(Trim(InputBox("输入错误。请重新输入生成PDF的方式：" & vbCrLf & "1：另存" & vbCrLf & "2：导出" & vbCrLf & "3：打印", "方式选择", 2)))
            Loop
            'Application.ScreenUpdating = False
            For j = LBound(drr) To UBound(drr)
                Rem 此处以下为调用的处理过程
                fName = Replace(drr(j), fso.GetExtensionName(drr(j)), "PDF")
                Set prs = Presentations.Open(drr(j))

                Select Case cType
                    Case 1
                        Call PPT另存PDF(prs, fName)
                    Case 2
                        Call PPT导出PDF(prs, fName)
                    Case 3
                        Call PPT打印PDF(prs, fName)
                End Select

                prs.Close
                Rem 此处以上为调用的处理过程
                Debug.Print Format(j, String(Len(CStr(UBound(drr))), "0")), drr(j), "打印完成"
            Next
            'Application.ScreenUpdating = False
        End If
    End With

    Set fd = Nothing
    Set fso = Nothing
    Set myFolder = Nothing
    Set prs = Nothing

    Debug.Print "完成   共打印了" & UBound(drr) & "个文件   用时" & Timer - t0 & "秒"
End Sub

Rem 此处以下为3种生成PDF的不同方式
Sub PPT打印PDF(prs As Presentation, fName As String)
    With prs.PrintOptions
        .Collate = msoTrue
        .FitToPage = msoTrue
        .FrameSlides = msoCTrue '加边框
'        .OutputType = ppPrintOutputSixSlideHandouts
        .OutputType = ppPrintOutputSlides
        .PrintColorType = ppPrintColor
    End With
    prs.PrintOut printtofile: fName
End Sub

Sub PPT导出PDF(prs As Presentation, fName As String)
    prs.ExportAsFixedFormat2 fName, ppFixedFormatTypePDF, ppFixedFormatIntentPrint, True, _
        ppPrintHandoutHorizontalFirst, ppPrintOutputSlides, includedocproperties:=True
End Sub

Sub PPT另存PDF(prs As Presentation, fName As String)
    prs.SaveAs fName, ppSaveAsPDF, msoTriStateMixed
End Sub

三、补充

关于具体的操作方法和Word批量导出PDF的方法，请关注我之前的专栏文章

守候：Word VBA：批量转PDF且保留书签https://zhuanlan.zhihu.com/p/540316455

有其他任何VBA/办公自动化的问题也可以提问或者浏览我的主页的回答和文章。