VBA insert image from url and lock original aspect ratio even when resizing columns and rows

[ojkaiko]

Hello there

I found myself using VBA for the first time because I'm trying to reach the goal of inserting an image from a url and then locking the original aspect ratio even when resizing columns and rows.

I apologize in advance for my complete lack of knowledge, I would really appreciate it if anyone can please help me out!

The code I got from someone on youtube is this:

Sub InsertImageVideo()

Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim item As Range

Set rng = Range("k2:k100")
For Each item In rng
    pic = item.Offset(0, 1)
    If pic = "" Then Exit Sub
        Set myPicture = ActiveSheet.Pictures.Insert(pic)
        
        With myPicture
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = item.Width
        .Height = item.Height
        .Top = Rows(item.Row).Top
        .Left = Columns(item.Column).Left
        .Placement = xlMoveAndSize

        
    End With
    
Next

        


End Sub






••••ˇˇˇˇ

But that doesn't really perfectly work for me becuase some of my images from the url are portrait and some are landscape, in fact most of them have different aspect ratios.

The first issue is that this code inserts the image filling up the width and height of the cell (which is distorting the image now) so they either look too fat or too narrow. I want them to be inserted with their original aspect ratio. However within the maximum capacity of the cell size.

The 2nd issue is that if I resize the column left or right, it will stretch the image, same goes with dragging the row up or down. I want excel to only scale up or down the size of the image if only there is enough room for the aspect ratio to scale up or down. This means I would have resize both column and row for that, and thats fine for me.

Any help would be appreciated, and I apologize for my lack of knowledge!

 

[Anthony47]

See the lines marked <<<; I think those modifications should address your concerns:

        With myPicture
            .ShapeRange.LockAspectRatio = msoTrue    '<<< msoFalse
            .Width = item.Width
            If .Height > item.Height Then .Height = item.Height    '<<<
            .Top = Rows(item.Row).Top
            .Left = Columns(item.Column).Left
            .Placement = xlFreeFloating        ''<<<  xlMoveAndSize
        End With

Bye