Resizing all shapes selected to the smallest shape - vba

Question

I've searched for a macro that will resize all selected shapes to the same height and width as the smallest selected shape, but haven't had any luck. I did find the following code which successfully resizes all selected shapes to the same height and width as the largest selected shape. I thought if I simply reversed each of the ">"s and "<"s then the code would meet my need, but it doesn't work. It resizes everything to .01"x.01" no matter the size of the smallest selected shape. Would someone mind letting me know what I need to tweak in the code below? Apologies in advance for the formatting - first post.
Sub resizeAll()
Dim w As Double
Dim h As Double
Dim obj As Shape
w = 0
h = 0
' Loop through all objects selected to assign the biggest width and height to w and h
For i = 1 To ActiveWindow.Selection.ShapeRange.Count
Set obj = ActiveWindow.Selection.ShapeRange(i)
If obj.Width > w Then
w = obj.Width
End If
If obj.Height > h Then
h = obj.Height
End If
Next
' Loop through all objects selected to resize them if their height or width is smaller than h/w
For i = 1 To ActiveWindow.Selection.ShapeRange.Count
Set obj = ActiveWindow.Selection.ShapeRange(i)
If obj.Width < w Then
obj.Width = w
End If
If obj.Height < h Then
obj.Height = h
End If
Next
End Sub

Answer 1

Try this instead:
Sub ResizeToSmallest()
' PPT coordinates are Singles rather than Doubles
Dim sngNewWidth As Single
Dim sngNewHeight As Single
Dim oSh As Shape
' Start with the height/width of first shape in selection
With ActiveWindow.Selection.ShapeRange
sngNewWidth = .Item(1).Width
sngNewHeight = .Item(1).Height
End With
' First find the smallest shape in the selection
For Each oSh In ActiveWindow.Selection.ShapeRange
If oSh.Width < sngNewWidth Then
sngNewWidth = oSh.Width
End If
If oSh.Height < sngNewHeight Then
sngNewHeight = oSh.Height
End If
Next
' now that we know the height/width of smallest shape
For Each oSh In ActiveWindow.Selection.ShapeRange
oSh.Width = sngNewWidth
oSh.Height = sngNewHeight
Next
End Sub
Note that this will either distort the shapes or result in the width being adjusted to a different size in order to maintain the shape's aspect ratio depending on the shape's .LockAspectRatio setting.

Answer 2

Sub ImageSizeToShortest()
Dim sAspectRatio As Single, i As Integer, r As Range, h As Single
h = Selection.PageSetup.PageHeight
Set r = Selection.Range
With ActiveDocument
For i = 1 To .Shapes.count
.Shapes(i).Select
If Selection.Start >= r.Start And Selection.End <= r.End Then
If h > .Shapes(i).Height Then h = .Shapes(i).Height
End If
Next i
For i = 1 To .InlineShapes.count
.InlineShapes(i).Select
If Selection.Start >= r.Start And Selection.End <= r.End Then
If h > .InlineShapes(i).Height Then h = .InlineShapes(i).Height
End If
Next i
For i = 1 To .Shapes.count
.Shapes(i).Select
If Selection.Start >= r.Start And Selection.End <= r.End Then
sAspectRatio = .Shapes(i).Width / .Shapes(i).Height
.Shapes(i).Height = h
.Shapes(i).Width = .Shapes(i).Height * sAspectRatio
End If
Next i
For i = 1 To .InlineShapes.count
.InlineShapes(i).Select
If Selection.Start >= r.Start And Selection.End <= r.End Then
sAspectRatio = .InlineShapes(i).Width / .InlineShapes(i).Height
.InlineShapes(i).Height = h
.InlineShapes(i).Width = .InlineShapes(i).Height * sAspectRatio
End If
Next i
End With
r.Select
End Sub