Change height of an image while maintaining the width to height ratio in VBA

Question

After cropping the image, I wish to change the height of all images while maintaining the width to height ratio.

My code does not maintain the width to height ratio.

Sub resizeall()
Dim i As Long
With ActiveDocument
    For i = 1 To .InlineShapes.Count
        With .InlineShapes(i)
            .LockAspectRatio = msoTrue
            .Height = CentimetersToPoints(6.9)
        End With
    Next i
End With
End Sub

I tried

.LockAspectRatio = msoTrue
.Top = Range("B7").Top
.Left = Range("B7").Left
.ShapeRange.LockAspectRatio = msoTrue
.Height = CentimetersToPoints(6.9)

I could resize the image in Word by moving the corner of the image while pressing shift but there too many images.
I found https://www.mrexcel.com/board/threads/insert-and-resize-picture-maintaining-aspect-ratio.1010711/ but I don't understand it and can't incorporate it with my current code.

Answer 1

To resize all images to a common height you can use the following:

Sub resizeall()
    Dim i As Long
    Dim newHeight As Single: newHeight = CentimetersToPoints(6.9)
    With ActiveDocument
        For i = 1 To .InlineShapes.Count
            With .InlineShapes(i)
                .LockAspectRatio = msoTrue
                .Width = AspectWidth(.Width, .Height, newHeight)
                .Height = newHeight
            End With
        Next i
    End With
End Sub

Public Function AspectWidth(ByVal OrigWidth As Single, ByVal OrigHeight As Single, _
    ByVal newHeight As Single) As Single
    'Calculates the new width in relation to the supplied new height
    'maintaining the aspect ratio of the original width/height
    If OrigHeight <> 0 Then
        AspectWidth = (OrigWidth / OrigHeight) * newHeight
    Else
        AspectWidth = 0
    End If
End Function