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

After cropping the image, I wish to use macro to change the height of all image while maintaining the width to height ratio so that the image does not look weird . Currently, my code change the correct height but it 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

Any advice will be appreciated

I have try

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

I am a complete beginner , I been googling but it does not seem to work for me. I could resize the image in word by moving the corner of the image while pressing shift but there too many images. I found this forum 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.

CodePudding user response：

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