Resize all objects to first object selected

Hi everyone

I've been asked to update a ribbon, but I don't have the ppam's VBA code. One button I'm stuck on, that I need to recreate.

When you clicked 2 or more objects on a slide, you click the tool and you have a pop-up box with ticks you and remove, which changes all shapes to the first shape selected's width and/or height:

Width (tick)
Height (tick)

Any ideas please? I only found VGA that makes all shapes the same width / height as the largest object.

Thank you :)

Code:

---

Sub sameWidth()
Dim oshpR As ShapeRange
Dim S As Long
On Error Resume Next
Set oshpR = ActiveWindow.Selection.ShapeRange
For S = 2 To oshpR.Count
oshpR(S).Width = oshpR(1).Width
Next S
End Sub

---

I hope you can work out same height!

Thanks John!

I spent 5 days trying to recreate this tool from a PPAM file, even unzipping it to look for the code. You did it! Even better! Thanks again. You're a star :)

Hi John

I managed to work out the Height :)
Trying Fill Color to the first selected, this isn't working?

Sub sameFillColor()
Dim oshpR As ShapeRange
Dim S As Long
On Error Resume Next
Set oshpR = ActiveWindow.Selection.ShapeRange
For S = 2 To oshpR.Count
oshpR(S).FillColor = oshpR(1).FillColor
Next S
End Sub

Thank you in advance :)

Sorry John, I worked it out thanks to the debugger:

Sub sameFillColor()
Dim oshpR As ShapeRange
Dim S As Long
On Error Resume Next
Set oshpR = ActiveWindow.Selection.ShapeRange
For S = 2 To oshpR.Count
oshpR(S).Fill.ForeColor = oshpR(1).Fill.ForeColor
Next S
End Sub