如何设置图片宽高比？

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

我为 Worksheet 对象 声明并设置了变量，只是为了让 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.

如何设置图片宽高比？

How to set picture aspect ratio?

excel

vba