How to keep aspect ratio of images pasted from links using VBA? - excel

Question

I need help locking the aspect ratio of images in a VBA code which pastes into an excel file images from links using information in specific cells.
What I would like to know is how to lock the aspect ratio of these pasted images.
I have tried to change things but haven't been able to succeed in keeping the aspect ratio.
Any help would be greatly appreciated! Thanks,
Peter
ActiveWindow.Zoom = 100
On Error Resume Next
Dim Plage As Range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set Plage = Selection
lig = Plage.Cells(1).Row
col = Plage.Cells(1).Column
nbcel = 0
For Each cell In Plage
If cell.Value <> "" Then nbcel = nbcel + 1
Next cell
posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
posCol = CInt(posColstr)
If posCol = 0 Then posCol = 1
For i = 0 To nbcel - 1
Matiere = Cells(i + lig, col).Value
Cells(i + lig, posCol).Activate
With Cells(i + lig, posCol)
t = .Top
l = .Left
w = .Width
h = .Height
End With
ActiveSheet.Shapes.AddPicture Filename:="https://websiteimagelink.com/" & Matiere & ".null.null.null.null.null.jpg", linktofile:=msoFalse, savewithdocument:=msoCTrue, Top:=t, Left:=l, Width:=70, Height:=50
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Placement = xlMoveAndSize
Next i

Answer 1

Here's an example of how you can do it.
Edited to show how it fits in your code.
Sub InsertPics()
Const MAX_WIDTH As Long = 100 'max picture width
Const MAX_HEIGHT As Long = 100 'max height
Dim Plage As Range, url, rngPic As Range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set Plage = Selection
ActiveWindow.Zoom = 100
On Error Resume Next
posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
posCol = CInt(posColstr)
If posCol = 0 Then posCol = 1
For Each c In Plage.Cells 'loop over user selection
Matiere = Trim(c.Value)
If Len(Matiere) > 0 Then 'if cell has a value...
url = "https://websiteimagelink.com/" & Matiere & ".null.null.null.null.null.jpg"
Set rngPic = c.EntireRow.Cells(posCol)
InsertResizePic rngPic, url, MAX_WIDTH, MAX_HEIGHT 'or rngpic.Width, rngpic.Height
End If
Next i
End Sub
'Insert a shape from path `pth`, positioned at cell `c`: resize so dimensions do
' not exceed `maxWidth` or `maxHeight`
Sub InsertResizePic(c As Range, pth As String, maxWidth As Long, maxHeight As Long)
Dim fW, fH, shp
Set shp = c.Parent.Pictures.Insert(Filename:=pth)
With shp
.ShapeRange.LockAspectRatio = msoTrue 'lock relative h/w
.Placement = xlMoveAndSize
.Top = c.Top
.Left = c.Left
fW = .Width / maxWidth 'dimensions relative to max allowed
fH = .Height / maxHeight
If fW > 1 Or fH > 1 Then 'is it too wide or too tall?
If fW >= fH Then
.Width = .Width / fW 'more too wide than too tall: shrink width
Else
.Height = .Height / fH 'shrink height
End If
End If
End With
End Sub