| |
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.
' Copyright ©1999-2022 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
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
|