在 VBA 中更改图像的高度，同时保持宽高比

Question

裁剪图像后，我希望更改所有图像的高度，同时保持宽高比。

我的代码不保持宽高比。

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

我试过了

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

我可以在 Word 中通过按住 Shift 键移动图像的一角来调整图像大小，但图像太多。
我发现 https://www.mrexcel.com/board/threads/insert-and-resize-picture-maintaining-aspect-ratio.1010711/ 但我不理解它，无法将其与我当前的代码。

Answer 1

要将所有图像的大小调整为通用高度，您可以使用以下命令：

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