合并PPT_Powerpint文件_保持主题颜色/Merge PowerPoint Keep Source Format

问题呈述/Problem Statement

微软的三大件用得太多了，并且是真的香。譬如，在汇报工作时，就会使用Powerpoint(以下用PPT代称)。但是由于每个人所使用的模板与样式是不同的，而在报告的时候，有时又需要把这些文件合并到一个PPT里，这可真是一个麻烦事儿。

Powerpoint (PPT) has been greatly used in daily presentation and report, and there are chances that you might merge severl PPTs with different design and themes into one. What is really a boring and tiring thing.

解决方案一/Solution 1

复制/粘贴，当然这是一个很蠢的方法，不过是一个解决之法，放出来供大家参考。The instinctive and stupid way to solve this is just Coping and Pasting.

  1. 首先，把所有需要合并的PPT都打开；
  2. 按Ctrl+N新建一个PPT，用B指代；
  3. 然后不断地在需要合并的PPT里全选Ctrl+A，复制Ctrl+C，然后切换到B里，移到到最后，鼠标点击一下，然后粘贴Ctrl+V， 此时，将会出现一个选项，在下面选择保持源格式/Keep Source Formatting即可。

  1. At first, open all the PPTs you want to merge.
  2. Press Ctrl+N to create a new PPT, referred as B.
  3. The all you should do is to Select All/Ctrl+A, Copy/Ctrl+C in source PPT, and then switch to destination PPT B, select where you want to insert the slides at the left most panel, press Paste/Ctrl+V, an option panel will show up, and you should select Keep Source Formatting to preserve the source format.

解决方案二/Solution 2

PowerPoint提供了一个方法：重用PPT，你可以在「主页→幻灯片→新建幻灯片→重用幻灯片」(「Home→Slides→New Slides→Reuse SLides」)里找到。这样就可以在右侧出现一个面板，用来选择对应的文件，然后插入幻灯片。注意，需要在插入之前勾选最下方的「保留源格式/Keep Source Formatting」。

PowerPoint provide a method named Reuse Slids, and therefore you can ulitize this function to imports slides following the hyperlink given before. Be caution, you should check [Keep Source Formatting] before you reuse any slides in order to preserve the format.

解决方法三/Solution 3

说实话，上面的方案都不好用，为什么呢？因为一旦文件多起来，你就只有浪费一上午在这上面了。所以还需要其它方法。

VBA当然会是一个好的方法，但是呢，Powerpoint里的VBA不像Excel里那么方便，并没有提供录制宏的功能，所以一切都需要自力更生，去网上找代码，找参考。

最终，从网上的内容里拼凑出了如下的代码。最关键的内容可以在代码里找到出处。当然，还找到了非常多的其它内容，但是要么不好用，要么已经在这个内容里包含了，所以就未一一地给出链接了。

使用方法：

  1. 把所有需要合并的文件放到一个文件夹里。
  2. 新建一个PPT，用来保存合并后的内容。
  3. 按Alt+F11，打开宏编辑器，在「Project」面板，「Insert→Module」，并打开该Module；
  4. 把下面的代码全部复制到右侧编辑框；
    1. 方法一：把光标移动到MergeAllPptFromSelectFolder这个Sub里，F5运行。
    2. 方法二：直接运行，选择MergeAllPptFromSelectFolder这个Sub。
  5. 直接下来会提示让你选择需要合并的文件在哪个文件夹里，你只需要选中这个文件夹就好了。
  6. 接下来会把所有的PPT,PPTX文件合并当前打开的PPT里，你可以进行接下来的保存工作了。

Actually, Solution 1 and 2 is time-cosuming, boring and tiring, for that you shall spend a whole morning acting repeatly.

VBA(VBScript for Application) is designed to handle such situation. However, VBA in Powerpoint isn't as convenient as that in Excel, since no Record Macro is provided. We have to spend days and nights for seeking codes and reference.

Fortunately, I worked out and the code is combined as follows. The critical reference is given in the code, and many others are ignored, unnecessary or repeating.

Usage:

  1. Put all the PPTs into one folder;
  2. Create a new PPT to contain the merged content;
  3. Press Alt+F11 to open the marco editor, in [Project] panel, [Insert→Module], and open the module;
  4. Paste the code below to the text editor,
    1. Method 1: Place the cursor in Sub MergeAllPptFromSelectFolder and the press F5,
    2. Method 2: Or you can just press F5 and the select MergeAllPptFromSelectFolder to run it.
  5. And you will be noticed to select the folder contains all the source PPTs, just get it;
  6. All the content will be mgered, and you can perform actions such as Save as.
' FROM https://stackoverflow.com/questions/5316459/programmatically-combine-slides-from-multiple-presentations-into-a-single-presen
' Copyright ?1999-2018 Shyam Pillai, All Rights Reserved.
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.



Option Explicit
Sub MergeAllPptFromSelectFolder()
    ' ScreenUpdating(FindWindowHandle(Application)) = False
    Dim SrcDir As String, SrcFile As String
    SrcDir = PickDir()
    If SrcDir = "" Then Exit Sub
    SrcFile = Dir(SrcDir & "\*.ppt")
    Do While SrcFile <> ""
        ImportFromPPT SrcDir + "\" + SrcFile, 1, 2
        SrcFile = Dir()
    Loop
    ' ScreenUpdating(FindWindowHandle(Application)) = True 'or False
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
    PickDir = ""
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
        .Title = "Pick a directory to work on"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 0 Then
            PickDir = .SelectedItems(1)
        End If
    End With
End Function
Private Sub ImportFromPPT(FileName As String, SlideFrom As Long, SlideTo As Long)
    Dim SrcPPT As Presentation, srcSlide As Slide, Idx As Long, SldCnt As Long
    Dim i As Long
    Dim bMasterShapes As Boolean
    ActivePresentation.Slides.InsertFromFile FileName, 0
    Set SrcPPT = Presentations.Open(FileName, , , msoFalse)
    SldCnt = SrcPPT.Slides.Count
    i = 1
    For Each srcSlide In SrcPPT.Slides
        Debug.Print "i = " & i
		' Copy from: https://stackoverflow.com/questions/5316459/programmatically-combine-slides-from-multiple-presentations-into-a-single-presen
        ActivePresentation.Slides(i).Design = srcSlide.Design
        ActivePresentation.Slides(i).ColorScheme = srcSlide.ColorScheme
        i = i + 1
    Next
    SrcPPT.Close
End Sub

解决方法四/Solution 4

方法三已经可以用了，但是了，我不想每次合并的时候都去新建一个PPT，然后复制，粘贴，运行，很麻烦，不是吗？所以又在上面的基础上进行了修改。

  1. 你可以把下面的代码保存到一个VBS文件里，譬如Merge_All_PPT.vbs；
  2. 把所有需要合并的PPT文件放到一个文件夹里，并且把之前保存的VBS文件也放到里面去；
  3. 双击运行，等待运行成功。在这个文件夹的上层目录里会增加一个__Batch__Merged__.pptx文件，确认过眼神，就是它了。
  4. 注意：由于VBS不安全，所以系统可能会提示你让你决定是否运行该VBS文件，让它运行即可。

Solution 3 works well despite that you do: open powerpoint, create a new PPT, open macro editor, copy, paste and run. How boring it is! Isn't it? So small modifications are done.

  1. You can copy the code below into a VBS file, such as Merge_All_PPT.vbs;
  2. Put al l the source PPTs as well as the VBS file into a folder;
  3. Double click to run the script, and all you should do is to wait until everything done.
  4. You can find the result file named as __Batch__Merged__.pptx in the parent folder.
  5. Caution: You might be warned for security reasons since VBS file is kind of dangerous. All you should do is to let it run.
' The original of version of merge PowerPoint comes from:
' https://www.tek-tips.com/viewthread.cfm?qid=1687770

' And some features are added:
' 1. Apply to current folder
' 2. Copy Design and ColorScheme from original slides


' --------------------------------------------------
' Version 2
' --------------------------------------------------
Dim Application
Const PPTMERGE_FILE   = "__Batch__Merged__.pptx"
PPTMERGE_FOLDER = WScript.CreateObject("wscript.shell").CurrentDirectory
Set Application       = CreateObject("PowerPoint.Application")
Application.Visible   = True
Dim first
first = True
Set fs=CreateObject("Scripting.FileSystemObject")
Dim folder
Set folder = fs.GetFolder(PPTMERGE_FOLDER)
Dim out
Dim ff
For Each ff in folder.Files
	If LCase(Right(ff.Path,3))="ppt"  OR LCase(Right(ff.Path,4))="pptx" Then
		f = PPTMERGE_FOLDER + "\" + ff.Name
		If first Then
			Dim p
			Set out = Application.Presentations.Open(ff)
			out.SaveAs PPTMERGE_FOLDER + "\..\" + PPTMERGE_FILE
			first = False
		Else
			out.Slides.InsertFromFile ff, 0
			Set SrcPPT = Application.Presentations.Open(ff.Path, , , msoFalse)
			SldCnt = SrcPPT.Slides.Count
			i = 1
			For Each srcSlide In SrcPPT.Slides
				Application.ActivePresentation.Slides(i).Design = srcSlide.Design
				Application.ActivePresentation.Slides(i).ColorScheme = srcSlide.ColorScheme
				i = i + 1
			Next
			SrcPPT.Close
		End If
	End If
Next

If Not first Then
	out.Save
	' out.SlideShowSettings.Run
End If
Application.Quit
Set folder = Nothing
Set out = Nothing
Set folder = Nothing
Set Application = Nothing
MsgBox "Merge Done!"

测试环境/Test on：

  1. Windows 10 Version 1909 (OS Build 18363.900)
  2. Microsoft PowerPoint 2016 MSO 64-bit

Update: 2021年05月22日

发现之前的内容还是有一些在复制过去之后存在格式不匹配的问题，因此通过网上找答案，找到了

ActivePresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

可以用来执行界面上悬浮菜单里的保留源格式，因此把代码更新如下：

'=============================================================================
'     FileName: Merge_All_PPT.vbs
'         Desc: 
'       Author: Troy Daniel
'        Email: Troy_Daniel@163.com
'     HomePage: https://www.cnblogs.com/troy-daniel
'      Version: 0.0.4
'   LastChange: 2021-05-19 17:16:40
'      History:
' 2021-05-19 . Use copy and paste with "Keep Source Format"
'=============================================================================
' 1. 把所有需要合并的PPT文件放到一个文件夹里，并且把之前保存的VBS文件也放到里面去；
' 2. 双击运行，等待运行成功。在这个文件夹的上层目录里会增加一个__Batch__Merged__.pptx文件，确认过眼神，就是它了。
' 3. 注意：由于VBS不安全，所以系统可能会提示你让你决定是否运行该VBS文件，让它运行即可。
' 
' The original of version of merge PowerPoint comes from:
' https://www.tek-tips.com/viewthread.cfm?qid=1687770

Dim Application

Const PPTMERGE_FILE = "__Batch__Merged__.pptx"
PPTMERGE_FOLDER     = WScript.CreateObject("wscript.shell").CurrentDirectory
Set Application     = CreateObject("PowerPoint.Application")
Application.Visible = True
Dim first
first = True
Set fs=CreateObject("Scripting.FileSystemObject")
Set outputLines = CreateObject("System.Collections.ArrayList")
Dim folder
Set folder = fs.GetFolder(PPTMERGE_FOLDER)
Dim out
Dim ff


for each ff in folder.Files
	If LCase(Right(ff.Path,3))="ppt"  OR LCase(Right(ff.Path,4))="pptx" Then
	  outputLines.Add PPTMERGE_FOLDER + "\" + ff.Name
	End If
next
outputLines.Sort()
' outputLines.Reverse()

For Each ff in outputLines

	If first Then
		Dim p
		Set out = Application.Presentations.Open(ff)
		out.SaveAs PPTMERGE_FOLDER + "\..\" + PPTMERGE_FILE
		first = False
	Else
		Set SrcPPT = Application.Presentations.Open(ff, , , msoFalse)
		SldCnt = SrcPPT.Slides.Count
		SrcPPT.Slides.Range.Copy
		out.Slides.Item(out.Slides.Count).Select
		' https://stackoverflow.com/questions/18457769/how-can-i-programatically-copy-and-paste-with-source-formatting-in-powerpoint-20 
		' method 2
		out.Application.ActivePresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
		
		SrcPPT.Close
	End If
Next

If Not first Then
	out.Save
End If

Application.Quit
Set folder = Nothing
Set out = Nothing
Set folder = Nothing
Set Application = Nothing
MsgBox "Merge Done!"
posted @ 2020-06-21 16:05  Troy_Daniel  阅读(817)  评论(0)  编辑  收藏  举报