Question

Sub ExampleUsage()
    Dim myPicture As String, myRange As Range
    myPicture = Application.GetOpenFilename _
        ("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", _
        , "Select Picture to Import")

    Set myRange = Selection
    InsertAndSizePic myRange, myPicture
End Sub

Sub InsertAndSizePic(Target As Range, PicPath As String)
    Dim p As Object
    Application.ScreenUpdating = False
    Set p = ActiveSheet.Pictures.Insert(PicPath)

    If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
    With Target
        p.Top = .Top
        p.Left = .Left
        p.Width = .Width
        p.Height = .Height
    End With
End Sub

这是我的Microsoft Excel代码。我希望宽高比解锁，以便我可以填充整个合并的单元格。提前谢谢。

Answer 1

这是你设置宽高比的方法。
它是形状对象的属性。 p属于Picture Object Type。您可以使用它的名称通过具有宽高比属性的Shapes来访问它：

Sub InsertAndSizePic(Target As Range, PicPath As String)
    Dim p As Object
    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = ActiveSheet
    Set p = sh.Pictures.Insert(PicPath)
    sh.Shapes(p.Name).LockAspectRatio = False

    If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
    With Target
        p.Top = .Top
        p.Left = .Left
        p.Width = .Width
        p.Height = .Height
    End With
    Application.ScreenUpdating = True
End Sub

我声明并为工作表对象设置变量，只是让Intellisense启动来获取参数。

另一种方法是使用Shape Object AddPicture Method，如下所示。

Sub InsertAndSizePic(Target As Range, PicPath As String)
    Dim s As Shape
    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = ActiveSheet

    If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
    With Target
        Set s = sh.Shapes.AddPicture(PicPath, True, True, .Left, .Top, .Width, .Height)
    End With
    Application.ScreenUpdating = True
End Sub

此代码也将完成第一个代码的功能。 HTH。

如何设置图片宽高比？

1 个答案: