VBA code to save a single slide as a .ppt

Question

I have a code which saves my specified slide as a 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"

However, I want to save the slide as a .PPT so that I can open it at a later date and edit the text on that slide. I have tried using the .SaveAs syntax, but I get an error message every time and it just won't recognise any 'Save' type expressions.

I have searched, and searched for the answer to this... Can anyone please help?

Answer 1

The following script will help you save the individual slides of your presentation as seperate pptx files. I modified @Steve Rindsberg code to achieve this.

Just change the following in the code

1. Change K:\PRESENTATION_YOU_ARE_EXPORTING.pptx with the file path of the presentation you are exporting.

2. Change K:\FOLDER PATH WHERE PPTX SHOULD BE EXPORTED\ with the folder path where the exported presentations should be saved.

3. Remember to add \ at the end of the folder path in Step 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
   

Answer 2

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

Above code exports Slide#1 to an 'old' type ppt format. The 2nd one of the following 2 macros can save a copy in a 'new' pptx format which is more compatible. It's actually the mixture of Steve's two methods. But it doesn't bother to delete the rest of the slides.

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 3

Sub 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 "Error encountered" Resume NormalExit End Sub

Answer 4

Try:

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

Alternative:

Use SaveCopy to save a copy of the presentation Open the saved copy (with or without a window) Delete all the slides up to the one you want to keep Delete all the slides after the one you want to keep Save again. Close the presentation

Like so:

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

Obviously, you'll want to add a few safety ropes ... don't try to export slide 15 of a 12-slide presentation, etc.

Answer 5

You could possibly try this code which:

1. creating new presentation
2. copying slide to it

3. saving & closing new presentation.

   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
   

You will need to adjust that code a bit but I think you'll cope :)