使用Powerpoint for macos自动合并pptx文件

'
' references:
' https://www.rondebruin.nl/mac/mac015.htm ' https://stackoverflow.com/questions/5316459/programmatically-combine-slides-from-multiple-presentations-into-a-single-presen ' https://msdn.microsoft.com/en-us/library/office/hh710200(v=office.14).aspx '

Sub MergePPTX()
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"

' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""org.openxmlformats.presentationml.presentation""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"

MyFiles = MacScript(MyScript)
On Error GoTo 0

If MyFiles <> "" Then
Presentations.Add
Dim fileName As String
MySplit = Split(MyFiles, ",")
For N = LBound(MySplit) To UBound(MySplit)
fileName = Replace(MySplit(N), "sys:", "/")
fileName = Replace(fileName, ":", "/")
ImportFromPPT fileName, 1, 2
Next N
End If
End Sub

Sub ImportFromPPT(fileName As String, SlideFrom As Long, SlideTo As Long)
Dim SrcPPT As Presentation, SrcSld As Slide, Idx As Long, SldCnt As Long

Set SrcPPT = Presentations.Open(fileName, , , msoFalse)
SldCnt = SrcPPT.Slides.Count

If SlideFrom > SldCnt Then Exit Sub
If SlideTo > SldCnt Then SlideTo = SldCnt

For Idx = SlideFrom To SlideTo Step 1
Set SrcSld = SrcPPT.Slides(Idx)
SrcSld.Copy
With ActivePresentation.Slides.Paste
.Design = SrcSld.Design
.ColorScheme = SrcSld.ColorScheme
' if slide is not following its master (design, color scheme)
' we must collect all bits & pieces from the slide itself

' >>>>>>>>>>>>>>>>>>>>

If SrcSld.FollowMasterBackground = False Then
.FollowMasterBackground = False
.Background.Fill.Visible = SrcSld.Background.Fill.Visible
.Background.Fill.ForeColor = SrcSld.Background.Fill.ForeColor
.Background.Fill.BackColor = SrcSld.Background.Fill.BackColor

' inspect the FillType object
Select Case SrcSld.Background.Fill.Type
Case Is = msoFillTextured
Select Case SrcSld.Background.Fill.TextureType
Case Is = msoTexturePreset
.Background.Fill.PresetTextured (SrcSld.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
' TextureName gives a filename w/o path
' not implemented, see picture handling
End Select

Case Is = msoFillSolid
.Background.Fill.Transparency = 0#
.Background.Fill.Solid

Case Is = msoFillPicture
' picture cannot be copied directly, need to export and re-import slide image
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = False
bMasterShapes = SrcSld.DisplayMasterShapes
SrcSld.DisplayMasterShapes = False
SrcSld.Export SrcPPT.Path & SrcSld.SlideID & ".png", "PNG"

.Background.Fill.UserPicture SrcPPT.Path & SrcSld.SlideID & ".png"
Kill (SrcPPT.Path & SrcSld.SlideID & ".png")

SrcSld.DisplayMasterShapes = bMasterShapes
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = True

Case Is = msoFillPatterned
.Background.Fill.Patterned (SrcSld.Background.Fill.pattern)

Case Is = msoFillGradient

' inspect gradient type
Select Case SrcSld.Background.Fill.GradientColorType

Case Is = msoGradientPresetColors
.Background.Fill.PresetGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Background.Fill.OneColorGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.GradientDegree
End Select

Case Is = msoFillBackground
' Only shapes - we shouldn't come here
End Select
End If

' >>>>>>>>>>>>>>>>>>>>

End With
Next Idx

End Sub