howto copy shapes from one slide to another during show

[anonymous]

I am trying to copy all the shapes from a slide to the current slide during a
show.
That is while presenting a show I click an object with an "Action Setting"
of run macro. The macro selects all shapes on a different slide and copies
them to the clipboard. Then using paste special they are overlayed on the
current slide.


Sub DisplayImageOfSlide()
Dim iCurrSlide As Integer
Dim iSlide As Integer
Dim lScale As Long
Dim lLeft As Long
Dim lTop As Long

iCurrSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
iSlide = 1
lScale = 50
lLeft = 300
lTop = 200

ActivePresentation.SlideShowWindow.View.GotoSlide iSlide

SlideShowWindows(Index:=1).View.Exit
ActiveWindow.ViewType = ppViewSlide
ActiveWindow.Selection.SlideRange.Shapes.SelectAll
ActiveWindow.Selection.Copy

ActiveWindow.View.GotoSlide iCurrSlide ' paste onto this slide

ActivePresentation.Slides(iCurrSlide).Shapes.PasteSpecial(ppPasteMetafilePicture).Select

With ActivePresentation.Slides(iCurrSlide).Shapes(2)
.ScaleWidth (lScale / 100), msoFalse
.ScaleHeight (lScale / 100), msoFalse
.IncrementLeft lLeft
.IncrementTop lTop
End With

ActivePresentation.SlideShowSettings.Run
ActivePresentation.SlideShowWindow.View.GotoSlide iCurrSlide

End Sub

 

[anonymous]

Thanks Steve,
But I need to copy all shapes as 1 object. This will then allow a mouse
click to delete them and redisplay the summary slide. I see it as a detailed
popup on the summary slide. Your code suggestion copies each shape separately.

 

[anonymous]

Enhancing your code I can get almost there. I just need a way of pasting all
copied shapes as 1 so the delete function can remove it in 1 click.

Sub DisplayImageOfSlide(oSh As Shape)
Dim lSlide As Long
Dim lScale As Long
Dim lLeft As Long
Dim lTop As Long
Dim x As Long
Dim oCurrentSlide As Slide
Dim oSourceSlide As Slide
Dim oSourceShape As Shape

lSlide = 1
lScale = 50
lLeft = 300
lTop = 200

Set oCurrentSlide = oSh.Parent
Set oSourceSlide = ActivePresentation.Slides(lSlide)

' copy each shape from source slide, paste to current slide
For Each oSourceShape In oSourceSlide.Shapes
oSourceShape.Copy
With oCurrentSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)(1)
.ScaleWidth (lScale / 100), msoFalse
.ScaleHeight (lScale / 100), msoFalse
.IncrementLeft lLeft
.IncrementTop lTop

With .ActionSettings(ppMouseClick)
.Run = "DeleteImageOfSlide"
.Action = ppActionRunMacro
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End With
Next

End Sub

Sub DeleteImageOfSlide(oSh As Shape)
Dim lSlide As Long
Dim lScale As Long
Dim lLeft As Long
Dim lTop As Long
Dim x As Long
Dim oCurrentSlide As Slide
Dim oSourceSlide As Slide
Dim oSourceShape As Shape

lSlide = 1
lScale = 50
lLeft = 300
lTop = 200

Set oCurrentSlide = oSh.Parent
oCurrentSlide.Shapes(2).Delete

End Sub

 

[anonymous]

I have come up with the following. Only problem is XY insertion point and
Scale are hardcoded. Is there a way to pass these into the macro from the
parent slide?


Sub DisplayImageOfSlide(oSh As Shape)
Dim lSlide As Long
Dim lScale As Long
Dim lLeft As Long
Dim lTop As Long
Dim oCurrentSlide As Slide
Dim oSourceSlide As Slide

lSlide = 1
lScale = 50
lLeft = 300
lTop = 200

Set oCurrentSlide = oSh.Parent
Set oSourceSlide = ActivePresentation.Slides(lSlide)

With ActivePresentation
.Slides(lSlide).Shapes.Range.Copy
With oCurrentSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.ScaleWidth (lScale / 100), msoFalse
.ScaleHeight (lScale / 100), msoFalse
.IncrementLeft lLeft
.IncrementTop lTop
With .ActionSettings(ppMouseClick)
.Run = "DeleteImageOfSlide"
.Action = ppActionRunMacro
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End With
End With

End Sub

Sub DeleteImageOfSlide(oSh As Shape)
Dim oCurrentSlide As Slide

Set oCurrentSlide = oSh.Parent
oCurrentSlide.Shapes(2).Delete

End Sub