Resizing all shapes selected to the smallest shape

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.