Copy object on button click and paste to summary slide

[MiloTT]

Hi,

Hope I can get some help on this. I've not been able to source any help that addresses my particular requirements..I'm not a VBA newbie but I wouldn't class myself as skilled either..

I have a presentation with many slides that is used as part of a client capability assessment. The presentation is divided up into several categories. On each new category slide the client is presented with a maximum of four descriptions (contained within a shape) that aligns with their organisation. When the client clicks on one of the shapes, through an assigned hyperlink action within the ppt, they will be directed to a new slide with their choice highlighted to validate their choice. They then move onto the next category by clicking on a separate progress shape which is hyperlinked to the next category introduction slide.

I would like to create a script/macro that will copy the shape selected on a particular slide including its containing text for each category and paste it to a summary slide at the end of the presentation. Barring that I would settle for just copying the whole slide. All of the hyperlink actions per category & shape are setup already I just need to complete the code per selection.

Any ideas? I have attached the pres with a sample category...

Thanks in advance

15201

[John Wilson]

The problem you face is:

A click on a shape can run a macro or a hyperlink but it cannot do both. You could make the macro move to the correct slide and copy/paste but that means a rethink. There are several ways to do this but I think this is the easiest

First:

Add this macro


Sub jumpandCopy(oshp As Shape)
oshp.Copy
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes.Paste
SlideShowWindows(1).View.GotoSlide (CLng(oshp.AlternativeText))
End Sub

Right Click a hyperlinked Rectange and Format Shape. Choose Alt Text and in Description type the slide number it should go to

Give it an action of Run Macro

Repeat for the other shapes using the same macro but the correct Alt Text

I uploaded a file where I have done some of this but there is more to do.

15202

[MiloTT]

Thanks John,

This is a great start. I can easily amend the slides to move onto the confirmation sections using the alt text option so no issues there. Now I just need to provide enough space on the competencies page for all possible selections or ,alternatively, create a new hidden page for each. They dont have to been seen anyway and are more for the sales and service consultants.

Tremendous help - much appreciated

[John Wilson]

See if you can play with this to get a better look.

Sub jumpandCopy(oshp As Shape)Dim targetSlide As Slide
Dim TSCount As Long
Set targetSlide = ActivePresentation.Slides(ActivePresentation.Slides.Count)
TSCount = targetSlide.Shapes.Count
oshp.Copy
With targetSlide.Shapes.Paste
.Width = .Width / 2
.Height = .Height / 2
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
If TSCount > 1 Then
.Left = targetSlide.Shapes(TSCount).Left + targetSlide.Shapes(TSCount).Width + 10
End If
End With
SlideShowWindows(1).View.GotoSlide (CLng(oshp.AlternativeText))
End Sub

[MiloTT]

Thanks again! I tried this out and it kind of works? The final slide has the selections but they are not centered like the previous version and the text box overflows out the shape?

This works the best to get all shapes just about onto one slide:

Sub jumpandCopy(oshp As Shape)
Dim targetSlide As Slide
Dim TSCount As Long
Set targetSlide = ActivePresentation.Slides(ActivePresentation.Slides.Count)
TSCount = targetSlide.Shapes.Count
oshp.Copy
With targetSlide.Shapes.Paste
.Width = .Width / 2
.Height = .Height / 1
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
If TSCount > 1 Then
.Left = targetSlide.Shapes(TSCount).Left + targetSlide.Shapes(TSCount).Width + 1
End If
End With
SlideShowWindows(1).View.GotoSlide (CLng(oshp.AlternativeText))
End Sub


How to now get it flowing from the left?
15214

[John Wilson]

Maybe (note none of this is being tested out!)


Sub jumpandCopy(oshp As Shape)
Dim targetSlide As Slide
Dim TSCount As Long
Set targetSlide = ActivePresentation.Slides(ActivePresentation.Slides.Count)
TSCount = targetSlide.Shapes.Count
oshp.Copy
With targetSlide.Shapes.Paste
.Width = .Width / 2
.Height = .Height / 1
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
If TSCount > 1 Then
.Left = targetSlide.Shapes(TSCount).Left + targetSlide.Shapes(TSCount).Width + 1
Else
.Left = 0
End If
End With
SlideShowWindows(1).View.GotoSlide (CLng(oshp.AlternativeText))
End Sub

[MiloTT]

Brilliant, even better, thanks John.

The shapes are now pasted in from the left and with some tweaking I have found the most appropriate sizing to fit them all on a single slide.

How would we now get the text re-sizing (auto re-size) per shape so that it fits inside each shape without flowing out the edges after selection? The text will re size if I edit the text outside of presentation mode.



Sub jumpandCopy(oshp As Shape) Dim targetSlide As Slide
Dim TSCount As Long
Set targetSlide = ActivePresentation.Slides(ActivePresentation.Slides.Count)
TSCount = targetSlide.Shapes.Count
oshp.Copy
With targetSlide.Shapes.Paste
.Width = .Width / 2.6
.Height = .Height / 0.7
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
If TSCount > 1 Then
.Left = targetSlide.Shapes(TSCount).Left + targetSlide.Shapes(TSCount).Width + 1
Else
.Left = 0
End If
End With
SlideShowWindows(1).View.GotoSlide (CLng(oshp.AlternativeText))
End Sub

[John Wilson]

AutosizeTextToFitShape really should work but I know it doesn't always in code. Strangely it did for me.(this time)

If it doesn't you could compare the .TextRange.BoundHeight with the height of the shape and reduce the font size in a loop till it fitted.

Or maybe try this


With targetSlide.Shapes.Paste

.Width = .Width / 2.6
.Height = .Height / 0.7
.TextFrame2.TextRange.Font.Size = 12 'new
.TextFrame2.Orientation = msoTextOrientationUpward 'new
'.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
If TSCount > 1 Then
.Left = targetSlide.Shapes(TSCount).Left + targetSlide.Shapes(TSCount).Width + 1
Else
.Left = 0
End If
End With

[MiloTT]

Just the ticket! I have amended it slightly and am now getting nicely re-sized and evenly spaced shapes with correctly sized text inside on the final slide as required.




Sub jumpandCopy(oshp As Shape)
Dim targetSlide As Slide
Dim TSCount As Long
Set targetSlide = ActivePresentation.Slides(ActivePresentation.Slides.Count)
TSCount = targetSlide.Shapes.Count
oshp.Copy
With targetSlide.Shapes.Paste
.Width = .Width / 3
.Height = .Height / 0.8
.TextFrame2.TextRange.Font.Size = 10
.TextFrame2.Orientation = msoTextOrientationUpward
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
If TSCount > 1 Then
.Left = targetSlide.Shapes(TSCount).Left + targetSlide.Shapes(TSCount).Width + 5
Else
.Left = 0
End If
End With
SlideShowWindows(1).View.GotoSlide (CLng(oshp.AlternativeText))
End Sub