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.

FYI its not my code. . . i borrowed it. I dont want to take credit — Dallas Barney, Jan 23 '15 at 02:54

L42 · Accepted Answer · 2015-01-23T03:38:51.040

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.

Thanks for you help that worked perfect. I don't know or understand code. This makes my job a lot easier i work with excel every day. — Dallas Barney, Jan 23 '15 at 14:39
@DallasBarney Glad it did. Btw, see [accepting answers](http://stackoverflow.com/help/someone-answers) as one way of saying **thank you** in SO. You can also [check this out](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros) to learn more on coding. Excel programming is object oriented so if you have a background in any programming language, it wouldn't be that hard. — L42, Jan 25 '15 at 21:43

How to set picture aspect ratio?

1 Answers1