博客

Sub 合并PPT()
    Dim t0 As Single: t0 = Timer
    Dim fdlog As FileDialog
    Dim prs As Presentation
    Dim prs1 As Presentation
    Dim sld As Slide
    Dim file
    Dim i As Integer
    
    Set prs = Presentations.Add
    Set fdlog = Application.FileDialog(msoFileDialogFilePicker)
    With fdlog
        .AllowMultiSelect = True
        With .Filters
            .Clear
            .Add "PPT文件", "*.ppt*;*.ppa*;*.pps*", 1
            .Add "所有文件", "*.*", 2
        End With
        If .Show Then
            i = 0
            For Each file In .SelectedItems
                Set prs1 = Presentations.Open(CStr(file))
                For Each sld In prs1.Slides
                    sld.Copy
                    prs.Slides.Paste prs.Slides.Count + 1
                Next
                prs1.Close
                i = i + 1
            Next
        End If
    End With
    
    Set fdlog = Nothing
    Set prs = Nothing
    Set prs1 = Nothing
    If i > 0 Then
        MsgBox Format(i, "完成，共合并了0个文件。") & Format(Timer - t0, "用时0.000秒。")
    End If
End Sub