Word 宏 VBA：使图像适合形状

Posted 2023-03-27

【中文标题】Word 宏 VBA：使图像适合形状

【英文标题】：Word macro VBA: Fit the image to the shape

【发布时间】：2022-01-15 05:23:37

【问题描述】：

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

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 的原始大小？或者是否可以在不将图像插入文档的情况下获取硬盘驱动器上任何图片的宽度和高度？谢谢

【问题讨论】：

你只需要图片尺寸吗？上面的代码将图片拉伸到形状容器尺寸。我可以告诉你如何提取尺寸（以像素为单位）

您的问题并不完全清楚，但我认为您想要的是将图片添加到形状中，如果图片的纵横比不同，则在较小的边上会出现深灰色条带.这是不可能的。形状可以有颜色填充或图像填充，不能同时有。

Timothy Rylatt 这是可能的。但这不是问题所在。问题是关于原始图像大小以计算纵横比。 @FaneDuru 这正是我想要的。如何获取图片的原始尺寸？

@Timothy Rylatt 哦，对不起，现在我明白你说的是什么了。我不知道您是否正确，但是可以通过某些（可能是默认的）背景来实现您描述的行为。也许你是对的，不可能将背景颜色与图像一起设置，但可以更改链接图像的尺寸以保持原始纵横比。

请编辑您的问题并描述您尝试复制的 UI 功能。 VBA 对象模型不包括 UI 的所有功能，因此可能没有直接的等价物，您需要考虑解决方法，例如将图像放入固定大小的单个单元格表中。

【参考方案1】：

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

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)

【参考方案2】：

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

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