Is there a way to copy slides programmatically keeping original
formatting of copied slides?
Shyam Pillai said:
Copy slides with source formatting (PowerPoint 2002/2003 )
http://skp.mvps.org/pptxp001.htm
Thanks. It works pretty well.
I've adapted the original code to preserve also user defined textured fill
and I've changed the sub to a function that works like standard Paste method
(it supports Index parameters and returns the pasted slides as a SlideRange)
and do a smart copy if source and target Presentations are the same.
______________
Option Explicit
Function CopySlideRangeAndPaste(sourceSlideRange As slideRange, targetSlides
As Slides, Optional Index As Long = -1) As slideRange
'Copies the slides in sourceSlideRange to targetSlides
'The first copied slide will be pasted at Index position
'or after last slide if Index = -1 (default).
'It returns the pasted slides as a SlideRange.
'Works like Paste method as for Index and returned SlideRange
If sourceSlideRange.Parent Is targetSlides.Parent Then
'If source and target Presentation is the same, do it the easy way
'by using Duplicate and Move methods
Set CopySlideRangeAndPaste = sourceSlideRange.Duplicate
If Index > 0 Then CopySlideRangeAndPaste.MoveTo Index
Exit Function
End If
Dim PastedSlideIndex As Long
If Index < 0 Then
PastedSlideIndex = targetSlides.Count
Else
PastedSlideIndex = Index - 1
End If
Dim SlidesNum() As Long
ReDim SlidesNum(1 To sourceSlideRange.Count)
Dim SlidesNumIndex As Long
Dim SourceSlide As Slide
For Each SourceSlide In sourceSlideRange
SourceSlide.Copy
PastedSlideIndex = PastedSlideIndex + 1
Dim TargetSlide As Slide
If Index < 0 Then
Set TargetSlide = targetSlides.Paste.Item(1)
Else
Set TargetSlide = targetSlides.Paste(PastedSlideIndex).Item(1)
End If
SlidesNumIndex = SlidesNumIndex + 1
SlidesNum(SlidesNumIndex) = PastedSlideIndex
With TargetSlide
.Design = SourceSlide.Design
' Apply the color scheme only after you have applied
' the design, else it won't give the desired results.
.ColorScheme = SourceSlide.ColorScheme
' Additional processing for slides which don't follow
' the master background
If Not SourceSlide.FollowMasterBackground Then
Dim SourceFill As FillFormat
Set SourceFill = SourceSlide.Background.Fill
.FollowMasterBackground = False
With .Background.Fill
.Visible = SourceFill.Visible
.ForeColor = SourceFill.ForeColor
.BackColor = SourceFill.BackColor
End With
Select Case SourceFill.Type
Case msoFillTextured
Select Case SourceFill.TextureType
Case msoTexturePreset
.Background.Fill.PresetTextured _
SourceFill.PresetTexture
Case 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.
CopyBackgroundImage SourceSlide, TargetSlide
End Select
Case msoFillSolid
.Background.Fill.Transparency = 0#
.Background.Fill.Solid
Case msoFillPicture
' No way to get the picture so export the slide image.
CopyBackgroundImage SourceSlide, TargetSlide
Case msoFillPatterned
.Background.Fill.Patterned _
(SourceFill.Pattern)
Case msoFillGradient
Select Case SourceFill.GradientColorType
Case msoGradientTwoColors
.Background.Fill.TwoColorGradient _
SourceFill.GradientStyle, _
SourceFill.GradientVariant
Case msoGradientPresetColors
.Background.Fill.PresetGradient _
SourceFill.GradientStyle, _
SourceFill.GradientVariant, _
SourceFill.PresetGradientType
Case msoGradientOneColor
.Background.Fill.OneColorGradient _
SourceFill.GradientStyle, _
SourceFill.GradientVariant, _
SourceFill.GradientDegree
End Select
Case msoFillBackground
' Only applicable to shapes.
End Select
End If
End With
Next SourceSlide
Set CopySlideRangeAndPaste = targetSlides.Range(SlidesNum)
End Function
Sub CopyBackgroundImage(SourceSlide As Slide, TargetSlide As Slide)
'Copy background image from SourceSlide to TargetSlide
'(As there isn't a support for this, it is accomplished by
'1. hiding every contets from foreground
'2. exporting the slide as a temporary image file (.png)
'3. loading the file as target background
'4. showing back hidden contents
'Define ImageTemporaryFileName
Dim fso As New FileSystemObject
With fso
Dim TemporaryFolderPath As String
TemporaryFolderPath =
..GetSpecialFolder(2).SubFolders.Add(.GetTempName).path
Dim ImageTemporaryFileName As String
With SourceSlide.Background.Fill
Select Case .Type
Case msoFillTextured
ImageTemporaryFileName = .TextureName
Case msoFillPicture
ImageTemporaryFileName = "Picture"
Case Else
ImageTemporaryFileName = "Background"
End Select
End With
ImageTemporaryFileName = .BuildPath(TemporaryFolderPath,
ImageTemporaryFileName & ".png")
End With
With SourceSlide
'1. hide every contets from foreground
If .Shapes.Count > 0 Then .Shapes.Range.Visible = False
Dim IsSourceSlideDisplayingMasterShapes As Boolean
IsSourceSlideDisplayingMasterShapes = .DisplayMasterShapes
.DisplayMasterShapes = False
'2. export the slide as a temporary image file (.png)
.Export ImageTemporaryFileName, "PNG"
'3. load the file as target background
TargetSlide.Background.Fill.UserPicture ImageTemporaryFileName
fso.DeleteFolder TemporaryFolderPath, True
'4. show back hidden contents
.DisplayMasterShapes = IsSourceSlideDisplayingMasterShapes
If .Shapes.Count > 0 Then .Shapes.Range.Visible = True
End With
End Sub
Function ArrayOfSlideIDs(slideRange As slideRange) As Long()
'Returns an array of the SlideID of every slide in slideRange
'(useful for NamedSlideShows.Add <ShowName>, <SlideIDs>)
Dim IDs() As Long
ReDim IDs(1 To slideRange.Count)
Dim i As Long
For i = 1 To slideRange.Count
IDs(i) = slideRange(i).SlideID
Next
ArrayOfSlideIDs = IDs
End Function
