Question

每周我都会将一个长PowerPoint文件分成不同的文件。这些文件必须是PowerPoint格式，并且只包含PowerPoint文件中“部分”中包含的幻灯片。

我需要：
1）扫描以查看给定部分中的幻灯片数量
2）制作一个包含该部分内幻灯片的文件 3）将该文件命名为与该部分名称相同的名称，并将其保存在与源文件相同的目录中 4）对后续章节重复此过程 5）在不损坏原始文件的情况下执行此操作。

我找到了可以将文件分成许多部分的代码（http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm），但仅限于每个文件请求的文件数。我在这里找到了一些其他有用的参考资料：http://skp.mvps.org/2010/ppt001.htm

我使用Basic编写了许多简单的游戏脚本语言。我需要帮助了解如何在VBA中完成此任务。

Answer 1

由于您经常这样做，您应该为此创建一个加载项。我们的想法是创建演示文稿的副本，直到其中的部分数量，然后打开每个部分并删除其他部分并保存。

创建启用了宏（* .pptm）的空白演示文稿，并可能添加自定义UI按钮以调用SplitIntoSectionFiles
测试并在满足时保存为PowerPoint加载项（* .ppam）。不要删除pptm文件！

假设您正在处理所有pptx文件，您可以使用此代码。它在后台打开分割的pptx文件，然后删除不相关的部分并保存，关闭。如果一切顺利，你会得到一个消息框。

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

如果您没有创建自己的功能区选项卡的经验，请阅读自定义UI：msdn并使用“Office自定义UI编辑器”，我会使用imageMso“CreateModule”作为按钮。{{0} }

Answer 2

所提议的例程都没有实际起作用，所以我从头开始写道：

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

我无法使用上述代码。

然而，这更简单并且确实有效：

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

我编辑了一些fabios代码看起来像这样。这在我的电脑上对我很有用

    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

这对我有用（文件名除外）：

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

将PowerPoint部分导出到单独的文件中

5 个答案: