How to set picture aspect ratio? - vba

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.