Word宏VBA：使图像适合形状

Question

我想使图像适合形状。 代码很简单：

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

但现在，图像填满了正方形。 我想适合图像。 我知道 Word 可以做到，但我相信我必须根据原始纵横比计算自己。 是否可以获得.UserPicture的原始大小？ 或者是否可以在不将图像插入文档的情况下获取硬盘驱动器上任何图片的宽度和高度？ 谢谢

Answer 1

我找到了适合我的解决方案。 我知道它并不理想，我不能说我喜欢它，但它已经足够了，它工作正常。 我在这里只发布一个片段：

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

Answer 2

请尝试下一个 function。 它将提取图像尺寸而不以任何方式导入：

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

它可能会替换上面代码中的导入行和picture声明：

   Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
    width = picture.width
    height = picture.height
    picture.Delete

和：

   Dim arr
   arr = ImgDimensions(sFile)
   width = arr(0): height = arr(1)