How to set picture aspect ratio?

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

This is my code for Microsoft Excel. I want to have the aspect ratio unlock so that I can fill the entire merged cell. Thanks in advance.

Answer 1

This is how you'll set the Aspect Ratio.
It is a Property of the Shape Object. p is of Picture Object Type. You can use it's name to access it via Shapes which has the Aspect Ratio property:

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

I declared and set variable for Worksheet Object just to have Intellisense kick in to get the arguments.

Another way is to use Shape Object AddPicture Method like below.

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

This code will also accomplish what the first code does. HTH.