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

I'm trying to copy all slides (preserving format) from an open presentation to a new one (except slide 2). I've got a block of code that seems to work if I step through it, but when I run it in presentation mode (or using Alt F8), only the last slide is copied to the new presentation the same number of times as there are original presentation slides.

Can anyone spot what I'm doing wrong? Thanks for your help!

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

CodePudding user response：

I found sort of silly solution. I save the current deck to a new copy, then just delete slide 2. Not sure if this is a preferred method or not.

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