Selecting and copying several objects and pasting them without losing their format

[RandomGerman]

Hi there,

I'm trying to copy some shapes with a macro from a presentation somewhere on the computer. An example could be a collection of maps and flags. So, e.g., on slide one I have the United States. 50 shapes (for each state),50 textboxes (their names) and one picture (the flag). And on slide 2 it is Germany. 16 shapes, 16 textboxes and 1 picture. So you never know, how many shapes you have to copy - the code should be flexible.

Parts of my code are already working. I have added comments and questions into the code, where things do not work the way I want them to.

Any help is appreciated.

Thank you,
RG



Sub CopyTest()
Dim src As Presentation
Dim trg As Slide
Dim shp As Shape
'Open the source presentation - this works fine.
Set Target = Application.Presentations.Open("C:\Users\Chef\Desktop\CopyTest.pptx")
Set src = Presentations("CopyTest.pptx")

'Select all shapes on the slide.
src.Slides(1).Shapes.SelectAll
'This works fine, as long as I try to select all on the first slide.
'When I changed Slides(1) to Slides(2), debugging said, for selecting the slide has to be active.
'How can I choose, which one is active?

'The next aspect, where I'm only close to my goal, is copying.
'I need to copy the selection, but the following is wrong,
'as ShapeRange(1) only copies one shape.
'How can I copy the whole selection?
Set shp = ActiveWindow.Selection.ShapeRange(1)
shp.Copy
'Close the source presentation - works well
With Application.Presentations("CopyTest.pptx")
.Close
End With
Set trg = ActiveWindow.View.Slide
'And finally paste it onto the active slide, my target.
'Seems to work, but the shapes lose their formatting.
'Is there a way to keep it with paste special?
'The copied shapes could be all kinds of objects:
'shapes, textboxes, groups, pictures, charts ...
trg.Shapes.Paste
End Sub

[John Wilson]

Try this:


Sub CopyTest()
Dim src As Presentation
Dim trg As Slide
Dim target As Presentation
'Open the source presentation - this works fine.
Set target = Application.Presentations.Open("C:\Users\Chef\Desktop\CopyTest.pptx")
Set src = Presentations("CopyTest.pptx")

'Select all shapes on the slide.
src.Slides(1).Shapes.SelectAll
'This works fine, as long as I try to select all on the first slide.
'When I changed Slides(1) to Slides(2), debugging said, for selecting the slide has to be active.
'How can I choose, which one is active?

'The next aspect, where I'm only close to my goal, is copying.
'I need to copy the selection, but the following is wrong,
'as ShapeRange(1) only copies one shape.
'How can I copy the whole selection?
ActiveWindow.Selection.ShapeRange.Copy
'Close the source presentation - works well
With Application.Presentations("CopyTest.pptx")
.Close
End With
Set trg = ActiveWindow.View.Slide
'And finally paste it onto the active slide, my target.
'Seems to work, but the shapes lose their formatting.
'Is there a way to keep it with paste special?
'The copied shapes could be all kinds of objects:
'shapes, textboxes, groups, pictures, charts ...
CommandBars.ExecuteMso ("PasteSourceFormatting")
End Sub

[RandomGerman]

CommandBars.ExecuteMso ("PasteSourceFormatting") - this is wonderful! Thanks again, John!

And for the selection problem (in case it is not slide 1) I found a solution by myself:


Sub CopyTest()
Dim src As Presentation
Dim trg As Slide
Dim target As Presentation
'Open the source presentation
Set target = Application.Presentations.Open("C:\Users\Chef\Desktop\CopyTest.pptx")
Set src = Presentations("CopyTest.pptx")

'Go to the wanted slide
ActiveWindow.View.GotoSlide (2)

'Select all shapes on the slide
src.Slides(2).Shapes.SelectAll

'Copy the whole selection
ActiveWindow.Selection.ShapeRange.Copy

'Close the source presentation
With Application.Presentations("CopyTest.pptx")
.Close
End With

'Go to target slide and paste, keeping format
Set trg = ActiveWindow.View.Slide
CommandBars.ExecuteMso ("PasteSourceFormatting")

End Sub

[John Wilson]

Just so you know the "PasteSourceFormatting" command was introduced in version 2010. If you try to use in earlier versions it will fail.

[RandomGerman]

Oh, that's really important. Is there a workaround for 2007?

[John Wilson]

No good one. You would have to set each feature individually which is a bit of a nightmare

[RandomGerman]

You mean something like "If Shape is a picture Then ...", "If Shape is a Table Then ..." and so on?

[John Wilson]

I mean
If it's a shape (for example)
Check the fill matches
Check the line is the same colour
Check line weight
Are there gradients to match
Is there text and if so what font
it goes on and on and trust me it's a nightmare

[RandomGerman]

Ah, ok. So every possibility needs any kind of definition. I understand. This seems to be a big pain indeed. Thanks for sharing your experience.