将所有幻灯片复制到新的 PPTX 仅适用于分步执行

Question

我正在尝试将打开的演示文稿中的所有幻灯片（保留格式）复制到新演示文稿（幻灯片 2 除外）。我有一段代码，如果我单步执行它似乎可以工作，但是当我运行它处于演示模式（或使用 Alt+F8）时，只有最后一张幻灯片被复制到新的演示文稿有原始演示幻灯片的次数。

谁能发现我做错了什么？感谢您的帮助！

Public Sub SaveAs()

    Dim oldPresentation As Presentation, newPresentation As Presentation
    Dim oldSlide As Slide
    Dim i As Integer, count As Integer, path As String, newFileName As String
    
    path = ActivePresentation.path
    count = ActivePresentation.Slides.count
    Set oldPresentation = ActivePresentation
    Set newPresentation = Application.Presentations.Add
        
    For i = 1 To count
    
        If i <> 2 Then
        
            Set oldSlide = oldPresentation.Slides(i)
            oldSlide.Copy
            newPresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
        
        End If
    
    Next i

    newFileName = "\Test " & Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") & ".pptx"
    newFileName = Replace(newFileName, ":", "-")

    With newPresentation
        .SaveCopyAs fileName:=path & newFileName, FileFormat:=ppSaveAsOpenXMLPresentation
    End With

    newPresentation.Close

End Sub

Answer 1

我发现了一种愚蠢的解决方案。我将当前幻灯片保存到一个新副本，然后只删除幻灯片 2。不确定这是否是首选方法。

Public Sub SaveAs()

    Dim oldPresentation As Presentation
    Dim newDeck As Presentation
    Dim path As String, newFileName As String
    
    path = ActivePresentation.path
    Set oldPresentation = ActivePresentation
    
    newFileName = "\HRB " & Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") & ".pptx"
    newFileName = Replace(newFileName, ":", "-")

    With oldPresentation
        .SaveCopyAs fileName:=path & newFileName, FileFormat:=ppSaveAsOpenXMLPresentation
    End With

    Set newDeck = GetObject(path & newFileName)
    newDeck.Slides(2).Delete
    
    newDeck.Save
    newDeck.Close

End Sub

将所有幻灯片复制到新的 PPTX 仅适用于分步执行

Copying All Slides to a new PPTX Only Works in Step Through

vba

powerpoint