合并某文件夹中的所有ppt幻灯片

lhm667788

在PowerPoint中按 Alt + F11 打开VBA编辑器。
Sub MergePresentations()
    Dim fd As FileDialog
    Dim folderPath As String
    Dim fileName As String
    Dim pres As Presentation
    Dim currentPres As Presentation
    Dim fileList As Collection
    Dim filePath As String
    Dim ext As String
    Dim arr() As String
    Dim i As Integer, j As Integer
    Dim temp As String
   
    Set currentPres = ActivePresentation
   
    ' 选择文件夹对话框
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "选择包含PPT文件的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1)
    End With
   
    ' 收集所有支持的PPT文件
    Set fileList = New Collection
    fileName = Dir(folderPath & "\*.*")
    Do While fileName <> ""
        If InStr(fileName, ".") > 0 Then
            ext = LCase(Mid(fileName, InStrRev(fileName, ".") + 1))
            Select Case ext
                Case "ppt", "pptx", "pptm", "pps", "ppsx"
                    fileList.Add fileName
            End Select
        End If
        fileName = Dir()
    Loop
   
    If fileList.Count = 0 Then
        MsgBox "未找到PPT文件！", vbExclamation
        Exit Sub
    End If
   
    ' 将文件名存入数组并排序
    ReDim arr(1 To fileList.Count)
    For i = 1 To fileList.Count
        arr(i) = fileList(i)
    Next i
   
    ' 冒泡排序（按文件名升序）
    For i = 1 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
   
    ' 合并幻灯片
    For i = 1 To UBound(arr)
        filePath = folderPath & "\" & arr(i)
        On Error Resume Next
        Set pres = Presentations.Open(filePath, ReadOnly:=msoTrue, WithWindow:=msoFalse)
        If Err.Number <> 0 Then
            MsgBox "无法打开文件: " & filePath, vbExclamation
            Err.Clear
        Else
            pres.Slides.Range.Copy
            pres.Close
            ' 粘贴到当前演示文稿末尾
            With currentPres
                If .Slides.Count = 0 Then
                    .Slides.Paste
                Else
                    .Slides.Paste(.Slides.Count + 1)
                End If
            End With
            DoEvents ' 确保粘贴操作完成
        End If
        On Error GoTo 0
    Next i
   
    MsgBox "合并完成！共处理 " & fileList.Count & " 个文件。", vbInformation
End Sub