vba 将 PowerPoint 部分导出到单独的文件中
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/18707249/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Exporting PowerPoint sections into separate files
提问by Peter Hogaboam
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.
每周我都会将一个很长的 PowerPoint 文件分成单独的文件。文件必须为 PowerPoint 格式，并且仅包含 PowerPoint 文件中“部分”中包含的幻灯片。
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.
我需要：
1) 扫描以查看给定部分中的幻灯片数量
2) 制作包含该部分中幻灯片的文件
3) 将该文件命名为与该部分名称相同的名称，并将其保存在与该部分相同的目录中源文件。
4) 对后续部分重复该过程。
5) 在不损坏原始文件的情况下执行此操作。
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
我找到了可以将文件分成多个部分的代码 ( http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm)，但仅限于每个文件请求的文件数。我在这里找到了一些其他有用的参考资料：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.
我用 Basic 和许多简单的游戏脚本语言编写代码。我需要帮助了解这是如何在 VBA 中完成的。
回答by PatricK
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!
- 创建启用宏的空白演示文稿 (*.pptm) 并可能添加自定义 UI 按钮以调用
SplitIntoSectionFiles - 测试并在满足时另存为 PowerPoint 加载项 (*.ppam)。不要删除pptm文件！
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.
假设所有都是你正在处理的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
Read about Custom UI if you don't have experience creating you own ribbon tab: msdnand use the "Office Custom UI Editor", I would use imageMso "CreateModule" for the button.
如果您没有创建自己的功能区选项卡的经验，请阅读自定义 UI：msdn并使用“Office 自定义 UI 编辑器”，我将使用 imageMso“CreateModule”作为按钮。
回答by Fabio
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
回答by Jithin Prakash
I have edited fabios code a bit to look like this. And this works well for me in my PC
我对 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
回答by Ksian
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
回答by K.R.
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
