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

CodePudding user response：

Please, try the next function. It will extract the image dimensions without importing in 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)

CodePudding user response：

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