如何逐张合并 2 个 PowerPoint 演示文稿？

不久前，我编写了一组宏来“堆叠”或“交错”多个文件中的幻灯片。

代码和说明位于我的网站之一：http : //www.pptools.com/merge/StackInterleave.pptm

代码受密码保护，但这里是进行交错的部分，用作您自己版本的起点。

将所有要合并的演示文稿放在一个没有其他文件的文件夹中：

Public Sub Interleave()
    Call InterleavePresentations(ActivePresentation.Path & "\")
End Sub

Sub InterleavePresentations(sDir As String)
' Assembles the slides from each presentation into one
' A1, B1, C1, A2, B2, C2 and so on

    Dim sTemp As String
    Dim oTempPres As Presentation
    Dim aFiles() As String
    Dim x As Long
    Dim lSlideCount As Long
    Dim lSlideNum As Long

    sTemp = Dir$(sDir & "*.ppt")
    If Len(sTemp) = 0 Then
        Exit Sub
    End If

    ReDim aFiles(1 To 1)

    ' fill the array with filenames (but NOT directory name)
    Do While Len(sTemp) > 0
        aFiles(UBound(aFiles)) = sTemp
        ReDim Preserve aFiles(1 To UBound(aFiles) + 1)
        sTemp = Dir$
    Loop

    ' find, open and save the first "valid" file from the directory
    For x = 1 To UBound(aFiles)
        If Len(aFiles(x)) > 0 Then
            If UCase(aFiles(x)) <> UCase("stackinterleave.pptm") Then
                If UCase(aFiles(x)) <> UCase("OUTPUT.PPTX") Then
                    Set oTempPres = Presentations.Open(sDir & aFiles(x))
                    Exit For
                End If
            End If
        End If
    Next

    If oTempPres Is Nothing Then
        MsgBox "Couldn't open " & sDir & aFiles(x)
        Exit Sub
    End If

    If Len(Dir$(sDir & "OUTPUT.PPTX")) > 0 Then
        Kill (sDir & "OUTPUT.PPTX")
    End If

    With oTempPres
        .SaveAs sDir & "OUTPUT.PPTX", ppSaveAsDefault
        lSlideCount = .Slides.Count
        .Slides.Range.Delete
        ' insert slides into the new empty presentation
        For lSlideNum = 1 To lSlideCount
            For x = 1 To UBound(aFiles)
                ' but not if the array element is blank
                If Len(aFiles(x)) > 0 Then
                    ' and not if its ME
                    If UCase(aFiles(x)) <> UCase("stackinterleave.pptm") Then
                        If UCase(aFiles(x)) <> UCase("OUTPUT.PPTX") Then

                            oTempPres.Slides.InsertFromFile aFiles(x), oTempPres.Slides.Count, lSlideNum, lSlideNum

                        End If
                    End If
                End If
            Next
        Next    ' lSlidenum
        .Save

    End With

End Sub