Can't insert picture in a spreadsheet using a link

Question

I've written a script in vba which uses Url in column b and insert the image in column c right next to the url. The script works when I use this image link but it fails when I use this image link . How can make my script do the trick even when I use the second link?

This is my try so far:

Sub InsertImages()
    Dim pics$, myPics As Shape, PicExists As Boolean, cel As Range

    For Each cel In Range("C2", Range("B2").End(xlDown).Offset(0, 1))
        PicExists = False
        pics = cel.Offset(0, -1)

        For Each myPics In ActiveSheet.Shapes
            If myPics.TopLeftCell.Row = cel.Row Then PicExists = True: Exit For
        Next myPics

        If Not PicExists Then
            With ActiveSheet.Pictures.Insert(pics)
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = cel.Width
                .Height = cel.Height
                .Top = Rows(cel.Row).Top
                .Left = Columns(cel.Column).Left
            End With
        End If
    Next cel
End Sub

Post script: Although my above script can insert picture making use of the first link, the image looks quite different from the source. To be clearer: the image becomes fatty.

Answer 1

(1) It seems that it is not possible to copy an image from amazon server with .picures.insert - this is probably because of Amazon, not Excel. However, downloading it as ADODB.Stream works, so that may be a work around. I made a test with the code from This answer and it worked.

(2) You explicitly set position and size of the image to an Excel cell and demands that the AspectRatio is not to be kept. If you set this to True , Excel automatically keeps the ratio between width and height - so changing the width will automatically also change the heigth (or vice versa).

If you want to keep the original size of the image, remove the lines that sets width and hight of the image:

With ActiveSheet.Pictures.Insert(pics)
   .ShapeRange.LockAspectRatio = msoTrue
   .Top = Rows(cel.Row).Top
   .Left = Columns(cel.Column).Left
End With

If you want to resize the image so that it fits into the cell:

With ActiveSheet.Pictures.Insert(pics)
    .ShapeRange.LockAspectRatio = msoTrue
    .Top = Rows(cel.Row).Top
    .Left = Columns(cel.Column).Left
    If .Width / .Height > cel.Width / cel.Height Then
        .Width = cel.Width
    Else
        .Height = cel.Height
    End If
End With