OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

Copy slides with source formatting (PowerPoint 2002+)
 

PowerPoint 2002 supports multiple masters, it's been a long requested feature. If you copy and paste slides thru the user interface, you get a smart tag option which gives you an option to retain source formatting of the slides being pasted/inserted. The smart tags cannot be manipulated in any way. 

The code snippet below explains how to copy slides while still retaining source formatting. Once you copy the slide, you can get a reference of the source slide design and set it to the target slide. This will add that design into the target presentation's design collection. You need to copy the color scheme of the source slide to ensure that the shape which follow the color scheme retain the same colors once copied.

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

 


Copyright 1999-2014 (c) Shyam Pillai. All rights reserved.