Exporting PowerPoint sections into separate files

问题

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.

回答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.

回答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

回答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

回答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

回答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

来源：https://stackoverflow.com/questions/18707249/exporting-powerpoint-sections-into-separate-files

标签

vba

powerpoint

powerpoint-vba