Сохранить каждый слайд как отдельный файл

Question

Я пытаюсь сохранить каждый слайд в виде отдельного файла, назвав его номером слайда с указанным ниже сценарием, но при этом сохраняется только выбранный слайд.

Sub TestMe()
    SaveSlide 5, "C:\G-Tools\export\test.pptx"
End Sub

Sub SaveSlide(lSlideNum As Long, sFileName As String)

    Dim oTempPres As Presentation
    Dim x As Long

    ActivePresentation.SaveCopyAs sFileName
    ' open the saved copy windowlessly
    Set oTempPres = Presentations.Open(sFileName, , , False)

    For x = 1 To lSlideNum - 1
        oTempPres.Slides(1).Delete
    Next

    ' What was slide number lSlideNum is now slide 1
    For x = oTempPres.Slides.Count To 2 Step -1
        oTempPres.Slides(x).Delete
    Next

    oTempPres.Save
    oTempPres.Close

End Sub

Answer 1

Вместо удаления всех других слайдов (что было решением, приведенным в этом ответе), вы можете создать новую презентацию для каждого слайда и скопировать ее в новую презентацию. Чтобы сохранить ту же цветовую гамму и дизайн, вы также должны скопировать это.

Option Explicit

Sub TestMe()
    SaveAllSlides "C:\Temp\myslides.pptx", True
End Sub

Sub SaveAllSlides(ByVal newFilename As String, _
                  Optional ByVal keepOpen As Boolean = False)
    Dim dotPosition As Long
    dotPosition = InStrRev(newFilename, ".")
    If dotPosition = 0 Then
        MsgBox "The filename is missing the pptx extension"
        Exit Sub
    End If

    Dim filepathNoExt As String
    filepathNoExt = Left$(newFilename, dotPosition - 1)

    Dim newPresentation As Presentation
    Dim thisPresentation As Presentation
    Set thisPresentation = ActivePresentation

    Dim i As Long
    For i = 1 To ActivePresentation.Slides.Count
        Set newPresentation = Presentations.Add
        thisPresentation.Slides(i).Copy
        With newPresentation
            .Slides.Paste Index:=1
            .Slides(1).Design = thisPresentation.Slides(i).Design
            .Slides(1).ColorScheme = thisPresentation.Slides(i).ColorScheme
            .SaveAs FileName:=filepathNoExt & Format(i, "00") & ".pptx"
            If Not keepOpen Then
                .Close
            End If
        End With
    Next i
End Sub