如何使用 VBA 在 Word 中将多个图像裁剪为相同大小，同时使其适合其容器形状

Posted 2023-02-25

【中文标题】如何使用 VBA 在 Word 中将多个图像裁剪为相同大小，同时使其适合其容器形状

【英文标题】：How to crop multiple images to same size while fitting them to their container shapes in Word using VBA

【发布时间】：2019-03-30 10:23:40

【问题描述】：

我想将 Word 文档中的多个图像调整为相同大小。对于单个图像，我可以设置其框架的高度和宽度，或者如果您愿意，可以设置容器形状，然后将图像填充到该框架。如何将这些程序翻译成VBA？

我编写了一个宏来调整多张图片的大小，但它不能很好地将一张图片填充到其框架中。这是代码：

Option Explicit

Sub crop_image()
' resize all selected inline images to specific dimensions

Dim i As Byte

'set desired width and height of an image.
Dim w As Single 'width
Dim h As Single 'height
Dim r As Single 'height-width ratio
w = 8
h = 5.5
r = h / w

With ActiveWindow.Selection
For i = 1 To .InlineShapes.Count
    With .InlineShapes(i)
        'if the image is tall & thin
        If .Height / .Width > r Then
            .Width = CentimetersToPoints(w)
            .PictureFormat.Crop.ShapeHeight = CentimetersToPoints(h)
        'if the image is short & fat
        ElseIf .Height / .Width < r Then
            .Height = CentimetersToPoints(h)
            .PictureFormat.Crop.ShapeWidth = CentimetersToPoints(w)
        End If
    End With
Next i
End With

End Sub

【问题讨论】：

不幸的是，您没有指定“其框架”的含义，使得这个问题对其他人毫无用处。

你认为这会让“框架”变得清晰吗？

【参考方案1】：

我自己想办法。

Sub crop_image()
' resize all selected inline images to specific dimensions

Dim i As Byte

'set desired width and height of an image.
Dim h As Single 'desired height
Dim w As Single 'desired width
Dim r As Single 'desired height-width ratio

h = CentimetersToPoints(6)
w = CentimetersToPoints(8)
r = h / w

Dim h0 As Single 'original height
Dim w0 As Single 'original width
Dim r0 As Single 'original height-width ratio

With activewindow.Selection
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
    'reset image
    With .PictureFormat.Crop
        h0 = .PictureHeight
        w0 = .PictureWidth
        r0 = h0 / w0
    End With

    If r0 > r Then      'if the image is tall & thin
    .Width = w
    With .PictureFormat.Crop
        .ShapeHeight = h
        .PictureWidth = w
        .PictureHeight = w * r0
    End With
    center .PictureFormat.Crop

    ElseIf r0 < r Then  'if the image is short & fat
    .Height = h
    With .PictureFormat.Crop
        .ShapeWidth = w
        .PictureHeight = h
        .PictureWidth = h / r0
    End With
    center .PictureFormat.Crop
    End If
End With
Next i
End With
End Sub

Function center(c As Crop) As Byte
c.PictureOffsetX = 0
c.PictureOffsetY = 0
End Function

不过，我期待一个更简洁的解决方案。