快速合并PPT

Option Explicit 
Sub CopyWithSourceFormating()
Dim oSource As Presentation
Dim oTarget As Presentation
Dim oSlide As Slide
Dim dlgOpen As FileDialog
Dim bMasterShapes As Boolean
Set oTarget = ActivePresentation
Set dlgOpen = Application.FileDialog(msoFileDialogOpen)
With dlgOpen
    .AllowMultiSelect = False
    .Filters.Clear
    .Filters.Add "Presentations", "*.ppt,*.pps"
    .Title = "Select Presentation to import"
    If .Show = -1 Then
        Set oSource = Presentations.Open(.SelectedItems(1), , , False)
    End If
    If oSource Is Nothing Then Exit Sub
End With
For Each oSlide In oSource.Slides
    oSlide.Copy
    With oTarget.Slides.Paste
        .Design = oSlide.Design
        ' Apply the color scheme only after you have applied
        ' the design, else it won't give the desired results.
        .ColorScheme = oSlide.ColorScheme
        ' Additional processing for slides which don't follow
        ' the master background
        If oSlide.FollowMasterBackground = False Then
            .FollowMasterBackground = False
            With .Background.Fill
                .Visible = oSlide.Background.Fill.Visible
                .ForeColor = oSlide.Background.Fill.ForeColor
                .BackColor = oSlide.Background.Fill.BackColor
            End With
            Select Case oSlide.Background.Fill.Type
            Case Is = msoFillTextured
                Select Case oSlide.Background.Fill.TextureType
                Case Is = msoTexturePreset
                    .Background.Fill.PresetTextured _
                        (oSlide.Background.Fill.PresetTexture)
                Case Is = msoTextureUserDefined
                ' TextureName gives only the filename
                ' and not the path to the custom texture file used.
                ' We could do it the same way we handle picture fill.
                End Select
            Case Is = msoFillSolid
                .Background.Fill.Transparency = 0#
                .Background.Fill.Solid
            Case Is = msoFillPicture
                ' No way to get the picture so export the slide image.
                With oSlide
                    If .Shapes.Count>0 Then .Shapes.Range.Visible=False
                    bMasterShapes = .DisplayMasterShapes
                    .DisplayMasterShapes = False
                    .Export oSource.Path & .SlideID & ".png", "PNG"
                End With
                .Background.Fill.UserPicture _
                    oSource.Path & oSlide.SlideID & ".png"
                Kill (oSource.Path & oSlide.SlideID & ".png")
                With oSlide
                    .DisplayMasterShapes = bMasterShapes
                    If .Shapes.Count>0 Then .Shapes.Range.Visible= True
                End With
            Case Is = msoFillPatterned
                .Background.Fill.Patterned _
                    (oSlide.Background.Fill.Pattern)
            Case Is = msoFillGradient
                Select Case oSlide.Background.Fill.GradientColorType
                Case Is = msoGradientTwoColors
                    .Background.Fill.TwoColorGradient _
                        oSlide.Background.Fill.GradientStyle, _
                        oSlide.Background.Fill.GradientVariant
                Case Is = msoGradientPresetColors
                    .Background.Fill.PresetGradient _
                        oSlide.Background.Fill.GradientStyle, _
                        oSlide.Background.Fill.GradientVariant, _
                        oSlide.Background.Fill.PresetGradientType
                Case Is = msoGradientOneColor
                    .Background.Fill.OneColorGradient _
                        oSlide.Background.Fill.GradientStyle, _
                        oSlide.Background.Fill.GradientVariant, _
                        oSlide.Background.Fill.GradientDegree
                End Select
            Case Is = msoFillBackground
                ' Only applicable to shapes.
            End Select
        End If
    End With
Next oSlide
oSource.Close
Set oSource = Nothing
End Sub