Word macro VBA: Fit the image to the shape - vba

Question

I would like to fit the image to the shape. The code is simple:
Function CmPt(cm As Single) As Single
' Convert centimeters to points.
CmPt = Application.CentimetersToPoints(cm)
End Function
Sub InsertCanvas()
' Insert puzzle image canvas to the document.
Dim edge As Single
edge = CmPt(4)
Dim canvas As Shape
Set canvas = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=CmPt(2.5), Top:=CmPt(2.5), Width:=edge, Height:=edge, Anchor:=Selection.Paragraphs(1).Range)
Dim image_path As String
image_path = ActiveDocument.Path & Application.PathSeparator & "images" & Application.PathSeparator & "image.jpeg"
With canvas
.Line.Weight = 1
.Line.ForeColor.RGB = RGB(64, 64, 64)
.Fill.Visible = msoTrue
.Fill.BackColor.RGB = RGB(255, 255, 255)
.Fill.UserPicture image_path
End With
End Sub
But now, the image is filling the square. I would like to fit the image. I know that Word can do it, but I believe I have to compute itself from the original aspect ratio. Is possible to get original size of the .UserPicture? Or is possible to get the width and height of any picture on the hard drive without inserting the image into the document? Thank you

Answer 1

Please, try the next function. It will extract the image dimensions without importing it in any way:
Function ImgDimensions(ByVal sFile As String) As Variant
Dim oShell As Object, oFolder As Object, oFile As Object, arr
Dim sPath As String, sFilename As String, strDim As String
sPath = Left(sFile, InStrRev(sFile, "\") - 1)
sFilename = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.Namespace(CStr(sPath))
Set oFile = oFolder.ParseName(sFilename)
strDim = oFile.ExtendedProperty("Dimensions")
strDim = Mid(strDim, 2): strDim = Left(strDim, Len(strDim) - 1)
arr = Split(strDim, " x ")
ImgDimensions = Array(CLng(arr(0)), CLng(arr(1)))
End Function
It may replace your importing lines from the code above, and picture declaration:
Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
width = picture.width
height = picture.height
picture.Delete
with:
Dim arr
arr = ImgDimensions(sFile)
width = arr(0): height = arr(1)

Answer 2

I found suitable solution for me. I know it is not ideal, and I can't say I like it, but it is enough and it is working correctly. I post only a snippet here:
Dim width As Long
Dim height As Long
Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
width = picture.width
height = picture.height
picture.Delete
Edit:
The whole vba code for Word macro
Function CmPt(cm As Single) As Single
' Convert centimeters to points.
CmPt = Application.CentimetersToPoints(cm)
End Function
Sub InsertPuzzleCard()
' Insert puzzle card to the document.
Dim edge As Single
edge = CmPt(4)
Dim canvas As Shape
Set canvas = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=CmPt(2.5), Top:=CmPt(2.5), width:=edge, height:=edge, Anchor:=Selection.Paragraphs(1).Range)
Dim image_path As String
image_path = ActiveDocument.Path & Application.PathSeparator & "images" & Application.PathSeparator & "image.jpeg"
Dim picture As Shape
Dim width As Long
Dim height As Long
Dim ratio As Single
Dim new_width As Long
Dim new_height As Long
Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
width = picture.width
height = picture.height
picture.Delete
ratio = width / height
If ratio < 1 Then
new_width = width * edge / height
new_height = edge
Else
new_width = edge
new_height = height * edge / width
End If
With canvas
.Line.Weight = 1
.Line.ForeColor.RGB = RGB(64, 64, 64)
.Fill.Visible = msoTrue
.Fill.UserPicture image_path
.PictureFormat.Crop.PictureWidth = new_width
.PictureFormat.Crop.PictureHeight = new_height
End With
End Sub