0

每周我都会将一个长的 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 中完成的。

4

5 回答 5

3

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

  1. 创建启用宏 (*.pptm) 的空白演示文稿，并可能添加自定义 UI 按钮以调用SplitIntoSectionFiles
  2. 测试并满足时，另存为 PowerPoint Add-In (*.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”作为按钮。创建模块

于 2013-09-10T03:29:44.823 回答
1

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

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
于 2015-12-28T13:23:13.483 回答
0

我无法让上面的代码工作。

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

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
于 2015-04-14T16:01:36.583 回答
0

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

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
于 2017-11-01T11:04:29.657 回答
0

我已经对 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
于 2016-05-07T12:25:42.417 回答