Exporting PowerPoint sections into separate files - vba

Question

Every week I separate a long PowerPoint file into separate files. The files must be in PowerPoint format, and contain only the slides that are contained in the 'sections' from the PowerPoint file.
I need to:
1) Scan to see the number of slides in a given section
2) Make a file containing the slides within that section
3) Name that file the same as the name of the section, and save it in the same directory as the source file.
4) Repeat the process for subsequent sections.
5) Do this without damaging the original file.
I've located code (http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm) that can break the file into many parts, but only by the number of files requested per file. I found some other helpful references here: http://skp.mvps.org/2010/ppt001.htm
I have coded in Basic and a number of easy gaming scripting languages. I need help understanding how this is done in VBA.

Answer 1

Since you do this very often, you should make an Add-In for this. The idea is to create copies of the presentation up to the number of sections in it, then open each one and delete the other sections and save.
Create blank presentation with macros enabled (*.pptm) and possibly add Custom UI button to call SplitIntoSectionFiles
Test and when satisfy, save as PowerPoint Add-In (*.ppam). Don't delete the pptm file!
Assuming that all are pptx files you are dealing with, you can use this code. It opens the splited pptx files in background, then remove irrelevant sections and save, close. If all goes well you get a message box.
Private Const PPT_EXT As String = ".pptx"
Sub SplitIntoSectionFiles()
On Error Resume Next
Dim aNewFiles() As Variant, sPath As String, i As Long
With ActivePresentation
sPath = .Path & "\"
For i = 1 To .SectionProperties.Count
ReDim Preserve aNewFiles(i)
' Store the Section Names
aNewFiles(i - 1) = .SectionProperties.Name(i)
' Force Save Copy as pptx format
.SaveCopyAs sPath & aNewFiles(i - 1), ppSaveAsOpenXMLPresentation
' Call Sub to Remove irrelevant sections
RemoveOtherSections sPath & aNewFiles(i - 1) & PPT_EXT
Next
If .SectionProperties.Count > 0 And Err.Number = 0 Then MsgBox "Successfully split " & .Name & " into " & UBound(aNewFiles) & " files."
End With
End Sub
Private Sub RemoveOtherSections(sPPT As String)
On Error Resume Next
Dim oPPT As Presentation, i As Long
Set oPPT = Presentations.Open(FileName:=sPPT, WithWindow:=msoFalse)
With oPPT
' Delete Sections from last to first
For i = .SectionProperties.Count To 1 Step -1
' Delete Sections that are not in the file name
If Not InStr(1, .Name, .SectionProperties.Name(i), vbTextCompare) = 1 Then
' Delete the Section, along with the slides associated with it
.SectionProperties.Delete i, True
End If
Next
.Save
.Close
End With
Set oPPT = Nothing
End Sub
Read about Custom UI if you don't have experience creating you own ribbon tab: msdn and use the "Office Custom UI Editor", I would use imageMso "CreateModule" for the button.

Answer 2

None of the proposed routines actually works, so I wrote mine from scratch:
Sub Split()
Dim original_pitch As Presentation
Set original_pitch = ActivePresentation
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With original_pitch
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
Dim i As Long
For i = 1 To original_pitch.SectionProperties.Count
Dim pitch_segment As Presentation
Set pitch_segment = Presentations.Open(Replace(original_pitch.FullName, "pptm", "pptx"))
section_name = pitch_segment.SectionProperties.Name(i)
For k = original_pitch.SectionProperties.Count To 1 Step -1
If pitch_segment.SectionProperties.Name(k) <> section_name Then pitch_segment.SectionProperties.Delete k, True
Next k
With pitch_segment
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, original_pitch.SectionProperties.Name(i) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Next i
MsgBox "Split completed successfully!"
End Sub

Answer 3

I could not get the above code to work.
However this is simpler and does work:
Sub SplitToSectionsByChen()
daname = ActivePresentation.Name
For i = 1 To ActivePresentation.SectionProperties.Count
For j = ActivePresentation.SectionProperties.Count To 1 Step -1
If i <> j Then ActivePresentation.SectionProperties.Delete j, True
Next j
ActivePresentation.SaveAs ActivePresentation.SectionProperties.Name(1)
ActivePresentation.Close
Presentations.Open (daname)
Next i
End Sub

Answer 4

I have edited fabios code a bit to look like this. And this works well for me in my PC
Option Explicit
Sub Split()
Dim original_File As Presentation
Dim File_Segment As Presentation
Dim File_name As String
Dim DupeName As String
Dim outputFname As String
Dim origName As String
Dim lIndex As Long
Dim K As Long
Dim pathSep As String
pathSep = ":"
#If Mac Then
pathSep = ":"
#Else
pathSep = "/"
#End If
Set original_File = ActivePresentation
DupeName = "TemporaryFile.pptx"
DupeName = original_File.Path & pathSep & DupeName
original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)
For lIndex = 1 To original_File.SectionProperties.Count
If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
File_name = File_Segment.SectionProperties.Name(lIndex)
For K = original_File.SectionProperties.Count To 1 Step -1
If File_Segment.SectionProperties.Name(K) <> File_name Then
Call File_Segment.SectionProperties.Delete(K, 1)
End If
Next K
outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")
With File_Segment
.SaveAs FileName:=.Path & outputFname & ".pptx", FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Set File_Segment = Nothing
End If
Next
Set original_File = Nothing
Kill DupeName
MsgBox "Split completed successfully!"
End Sub

Answer 5

This works for me (except for the filename):
Option Explicit
Sub ExportSlidesAsPresentations()
Dim oPres As Presentation
Dim sSlideOutputFolder As String
Set oPres = ActivePresentation
sSlideOutputFolder = oPres.Path & "\"
'Export all the slides in the presentation
Call oPres.PublishSlides(sSlideOutputFolder, True, True)
Set oPres = Nothing
End Sub