将单张幻灯片另存为 .ppt 的 VBA 代码

Question

我有一个代码可以将我指定的幻灯片另存为 PNG：

Dim userName As String
userName = Slide322.TextBox1.Text

'Save slide

ActivePresentation.Slides(302).Export _
        filename:="C:\Users\Jessica\Dropbox\Uni\DISSERTATION\Questionnaire\Tools\Results\" & userName & ".png", FilterName:="PNG"

但是，我想将幻灯片另存为 .PPT，以便我可以在以后打开它并编辑该幻灯片上的文本。 我曾尝试使用 .SaveAs 语法，但每次我都会收到一条错误消息，而且它无法识别任何“保存”类型的表达式。

我已经搜索过，并搜索过这个问题的答案......任何人都可以帮忙吗？

Answer 1

尝试：

ActivePresentation.Slides(1).Export "c:\temp\slide1.ppt", "PPT"

选择：

使用 SaveCopy 保存演示文稿的副本 打开保存的副本（带或不带窗口） 删除所有幻灯片，直到要保留的幻灯片 删除要保留的幻灯片之后的所有幻灯片 再次保存。 关闭演示文稿

像这样：

Sub TestMe()
    SaveSlide 5, "c:\temp\slide5.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

显然，您需要添加一些安全绳……不要尝试导出 12 张幻灯片演示的第 15 张幻灯片等。

Answer 2

您可以尝试使用以下代码：

1. 创建新演示文稿
2. 复制幻灯片到它

3. 保存和关闭新演示文稿。

    Sub SaveSeparateSlide() Dim curPres As Presentation Set curPres = ActivePresentation Dim newPres As Presentation Set newPres = Presentations.Add 'change slide number here: curPres.Slides(1).Copy newPres.Slides.Paste 'change your path and name here: newPres.SaveAs "single slide presentation.pptx" newPres.Close End Sub

您将需要稍微调整该代码，但我认为您会应付得来:)

Answer 3

子 SplitFile()

Dim lSlidesPerFile As Long
Dim lTotalSlides As Long
Dim oSourcePres As Presentation
Dim otargetPres As Presentation
Dim sFolder As String
Dim sExt As String
Dim sBaseName As String
Dim lCounter As Long
Dim lPresentationsCount As Long     ' how many will we split it into
Dim x As Long
Dim lWindowStart As Long
Dim lWindowEnd As Long
Dim sSplitPresName As String

On Error GoTo ErrorHandler

Set oSourcePres = ActivePresentation
If Not oSourcePres.Saved Then
    MsgBox "Please save your presentation then try again"
    Exit Sub
End If

lSlidesPerFile = CLng(InputBox("How many slides per file?", "Split Presentation"))
lTotalSlides = oSourcePres.Slides.Count
sFolder = ActivePresentation.Path & "\"
sExt = Mid$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") + 1)
sBaseName = Mid$(ActivePresentation.Name, 1, InStr(ActivePresentation.Name, ".") - 1)

If (lTotalSlides / lSlidesPerFile) - (lTotalSlides \ lSlidesPerFile) > 0 Then
    lPresentationsCount = lTotalSlides \ lSlidesPerFile + 1
Else
    lPresentationsCount = lTotalSlides \ lSlidesPerFile
End If

If Not lTotalSlides > lSlidesPerFile Then
    MsgBox "There are fewer than " & CStr(lSlidesPerFile) & " slides in this presentation."
    Exit Sub
End If

For lCounter = 1 To lPresentationsCount

    ' which slides will we leave in the presentation?
    lWindowEnd = lSlidesPerFile * lCounter
    If lWindowEnd > oSourcePres.Slides.Count Then
        ' odd number of leftover slides in last presentation
        lWindowEnd = oSourcePres.Slides.Count
        lWindowStart = ((oSourcePres.Slides.Count \ lSlidesPerFile) * lSlidesPerFile) + 1
    Else
        lWindowStart = lWindowEnd - lSlidesPerFile + 1
    End If

    ' Make a copy of the presentation and open it
    sSplitPresName = sFolder & sBaseName & _
           "_" & CStr(lWindowStart) & "-" & CStr(lWindowEnd) & "." & sExt
    oSourcePres.SaveCopyAs sSplitPresName, ppSaveAsDefault
    Set otargetPres = Presentations.Open(sSplitPresName, , , True)

    With otargetPres
        For x = .Slides.Count To lWindowEnd + 1 Step -1
            .Slides(x).Delete
        Next
        For x = lWindowStart - 1 To 1 Step -1
            .Slides(x).Delete
        Next
        .Save
        .Close
    End With

Next    ' lpresentationscount

NormalExit: Exit Sub ErrorHandler: MsgBox “遇到错误” Resume NormalExit End Sub

Answer 4

ActivePresentation.Slides(1).Export "1.ppt", "PPT"

上面的代码将 Slide#1 导出为“旧”类型的 ppt 格式。 以下 2 个宏中的第 2 个可以以更兼容的“新”pptx 格式保存副本。 它实际上是史蒂夫两种方法的混合。 但是删除其余的幻灯片并不麻烦。

Sub SaveEachPage2PPT()

Dim sld As Slide
Dim l#

With ActivePresentation
    For Each sld In .Slides
        l = l + 1
        sld.Export .Path & "\" & l & ".ppt", "PPT"
    Next sld
End With
End Sub

Sub SaveEachPage2PPTX()

Dim sld As Slide
Dim l#
Dim ppt As Presentation
Dim pptFile$

With ActivePresentation
    For Each sld In .Slides
        l = l + 1
        pptFile = .Path & "\" & l & ".ppt"
        sld.Export pptFile, "PPT"
        Set ppt = Presentations.Open(pptFile, , , False)
        ppt.SaveCopyAs pptFile & "x", ppSaveAsOpenXMLPresentation
        ppt.Close
        Kill pptFile
    Next sld
End With
If Not ppt Is Nothing Then Set ppt = Nothing

End Sub

Answer 5

以下脚本将帮助您将演示文稿的各个幻灯片保存为单独的 pptx 文件。 我修改了@Steve Rindsberg代码来实现这一点。

只需在代码中更改以下内容

1. 将K:\\PRESENTATION_YOU_ARE_EXPORTING.pptx更改为您要导出的演示文稿的文件路径。

2. 将K:\\FOLDER PATH WHERE PPTX SHOULD BE EXPORTED\\更改为应保存导出的演示文稿的文件夹路径。

3. 请记住在步骤 2 中的文件夹路径末尾添加 \\。

    Sub ExportSlidesToIndividualPPPTX() Dim oPPT As Presentation, oSlide As Slide Dim sPath As String Dim oTempPres As Presentation Dim x As Long ' Location of PPTX File Set oPPT = Presentations.Open(FileName:="K:\\PRESENTATION_YOU_ARE_EXPORTING.pptx") ' Location Where Individual Slides Should Be Saved ' Add \\ in the end sPath = "K:\\FOLDER PATH WHERE PPTX SHOULD BE EXPORTED\\" For Each oSlide In oPPT.Slides lSlideNum = oSlide.SlideNumber sFileName = sPath & "Slide - " & lSlideNum & ".pptx" oPPT.SaveCopyAs sFileName ' open the saved copy windowlessly Set oTempPres = Presentations.Open(sFileName, , , False) ' Delete all slides before the slide you want to save For x = 1 To lSlideNum - 1 oTempPres.Slides(1).Delete Next ' Delete all slides after the slide you want to save For x = oTempPres.Slides.Count To 2 Step -1 oTempPres.Slides(x).Delete Next oTempPres.Save oTempPres.Close Next Set oPPT = Nothing End Sub