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

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

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

编辑： Word 宏的完整 vba 代码

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

Answer 2

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

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)

Word宏VBA：使图像适合形状

Word macro VBA: Fit the image to the shape

vba

ms-word