prop. scale images - have code, just need slight mod

[cml0904]

Hi, I have a column of image urls and need to scale/size them in
proportion. I have code below that works well, BUT, in order to keep
the aspect ratio, I really need to choose height or width. Mostly this
works, but sometimes there is a very tall, skinny image that scales
down to a sliver.

This code also changes the line height to match the forced height of
the images. Again, works well, but not for every case.

How can I accommodate the odd images?

One more question please, when I sort data, I guess the images are
moving with their respective data, but they are floating, right? Is
there a way to anchor them to their cell/row?

Thanks a lot,
Cindy

-----------------------
Sub InsertPics()
'
For Each Item In Selection ' Go through each row the user has
selected...
ActiveSheet.Cells(Item.Row, 4).Select ' Select the cell in column
4
' Insert a picture using the address in column 6
ActiveSheet.Pictures.Insert(ActiveSheet.Cells(Item.Row,
6).Value).Select
Selection.ShapeRange.Height = 72# ' Set the picture width to 72
(one inch)
Selection.ShapeRange.LockAspectRatio = True
ActiveSheet.Rows(Item.Row).RowHeight = 72# ' Set the row height to
72 (one inch)
Next Item
Columns("D").ColumnWidth = 15 ' Set the column width to one inch
End Sub

 

[Tom Ogilvy]

Sub abc()
Dim aspectRT As Double
Dim nwWidth As Double
Dim shp As ShapeRange
Dim item As Range
Set item = Range("A6")
With ActiveSheet
Set shp = .Pictures.Insert(.Cells(item.Row, 6).Value).ShapeRange
End With
aspectRT = shp.Height / shp.Width
nwWidth = 72# / aspectRT
If nwWidth < 30 Then
' do what?
Else
shp.LockAspectRatio = True
shp.Height = 72# '
End If
End Sub