[FIXED] How to crop multiple images to same size while fitting them to their container shapes in Word using VBA

Issue

I want to resize multiple images to the same size in a Word document. For an individual image, I can set the height and width of its frame, or container shape if you will, then fill the image to that frame. How to translate these procedures into VBA?

I've written a macro to resize multiple images, but it doesn't work well to fill an image to its frame. Here is the code:

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

Solution

I figure it out myself.

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

I'm looking forward to a more concise solution though.

Answered By - David H. J.

Answer Checked By - Dawn Plyler (PHPFixing Volunteer)