Microsoft Office Forums - View Single Post - (.left property) and (LockAspectRatio) don't work

macropod · 06-12-2014, 10:45 PM

Try:

Code:

Sub Gen_InsertPicture()
Application.ScreenUpdating = False
Dim sPicture As String, pic As Picture
FilterPics = "All Pictures, *.gif;*.jpg;*.jpeg;*.jpe;*.bmp;*.png;*.tif"
sPicture = Application.GetOpenFilename(FilterPics, , "select picture")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic.ShapeRange
  .ScaleWidth 0.01, True, msoScaleFromTopLeft
  .ScaleHeight 0.01, True, msoScaleFromTopLeft
  .LockAspectRatio = msoTrue
  .Height = Selection.Offset(Selection.Rows.Count, 0).Top - Selection.Top
  If .Width > Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left Then
    .Width = Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left
  End If
  .Top = Selection.Top
  .Left = Selection.Offset(0, Selection.Columns.Count).Left - .Width
End With
pic.Placement = xlMoveAndSize
Set pic = Nothing
If ActiveSheet.CodeName = "Sheet9" Then
    With Range("DrwgArea").Interior
        .Pattern = xlNone
    End With
End If
Application.ScreenUpdating = True
End Sub

Note that the original scaling gets restored by setting it to 1% of the original size (you may be able to start of with something much larger - I don't know what your picture sizes are) before adjusting it to the cell size. Also, after adjusting the height, the width only gets re-adjusted if it's still greater than the cell width.