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

将每张幻灯片另存为单独的文件

1 个答案: