Forum Discussion

Jay_Rabe's avatar
Jay_Rabe
Copper Contributor
Feb 14, 2024
Solved

Fetching images from url, images shift up as row number increases - VBA codes (2)

I have 2 different VBA codes that have the same issue.  When the code fetches and pastes the images, they slowly start to shift up as the row number increases.

The first code is a bit crude - clamps the image height and width - or set keep aspect ratio to true and the images pop out of the cell.
Cell 6 you start to see the images shifted up.
Cell 88 you need to arrow down the pasted image 20x to be centered in the cell.
Cell 166 you need to arrow down 39x to align the pasted image into the cell.

 

 

 

 

Sub InsertPic()
Dim pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator

Set rng = Range("F166:F169")  '<~~ Modify this range as needed. Assumes image link URL in column A.
For Each cl In rng
pic = cl.Offset(0, -1)

    Set myPicture = ActiveSheet.Pictures.Insert(pic)
    '
    'you can play with this to manipulate the size & position of the picture.
    ' currently this shrinks the picture to fit inside the cell.
    With myPicture
        .ShapeRange.LockAspectRatio = msoTrue
        .width = cl.width
        .height = cl.height
        .Top = Rows(cl.Row).Top
        .Left = Columns(cl.Column).Left
    End With
    '

 Next

 End Sub

 

 

 



The second code scales the images to fit into the cell properly & without distortion but is still shifting the images up as the row number goes up.  We (ai helped) added a scaling factor to try to help combat this offset but there is an oddly small gap between the first and second image. Then the rest are ok for a while then drift again.

 

 

 

 

Sub InsertImages()
    Dim imgPath As String
    Dim cell As Range
    Dim ws As Worksheet
    Dim imgWidth As Single
    Dim imgHeight As Single
    Dim pic As Picture
    Dim targetRange As Range
    Dim scalingFactor As Double
    
    ' Set the scaling factor
    scalingFactor = 0.2 ' You can adjust this value to shift the images as row numbers increase
    
    ' Set the worksheet reference
    Set ws = ThisWorkbook.Sheets("Tab1") ' Change the sheet name as needed
    
    ' Define the target range (replace "E2:E5" with the desired range)
    Set targetRange = ws.Range("E292:E296")
    
    ' Loop through each cell in the target range
    For Each cell In targetRange
        ' Get the image path from the cell in column E
        imgPath = cell.Value
        
        ' Check if the image URL is not empty
        If imgPath <> "" Then
            ' Set maximum width and height
            imgWidth = 70
            imgHeight = 70
            
            ' Calculate the aspect ratio using another method
            Dim aspectRatio As Double
            aspectRatio = GetImageAspectRatio(imgPath)
            Debug.Print "Debug: Aspect Ratio - " & aspectRatio
            
            If aspectRatio > 0 Then
                ' Adjust width and height to maintain aspect ratio
                If aspectRatio >= 1 Then
                    ' Landscape orientation, set width and scale height
                    imgWidth = 70
                    imgHeight = 70 / aspectRatio
                Else
                    ' Portrait orientation, set height and scale width
                    imgHeight = 70
                    imgWidth = 70 * aspectRatio
                End If
                
                ' Debug: Print cell and image dimensions
                Debug.Print "Debug: Original CellTop - " & cell.Top
                Debug.Print "Debug: Original CellLeft - " & cell.Left
                Debug.Print "Debug: Cell Height - " & cell.height
                Debug.Print "Debug: Cell Width - " & cell.width
                
                ' Insert the image in the cell in Column F
                Set pic = ws.Pictures.Insert(imgPath)
                With pic
                    .ShapeRange.LockAspectRatio = msoTrue ' Lock the aspect ratio
                    .ShapeRange.width = imgWidth
                    .ShapeRange.height = imgHeight
                    
                    ' Calculate the cell position for better alignment
                    Dim cellTop As Single
                    Dim cellLeft As Single
                    cellTop = cell.Top + (cell.height - .ShapeRange.height * scalingFactor) / 2
                    cellLeft = ws.Range("F" & cell.Row).Left + (ws.Range("F" & cell.Row).width - .ShapeRange.width) / 2
                    
                    ' Debug: Print calculated cell position
                    Debug.Print "Debug: Calculated CellTop - " & cellTop
                    Debug.Print "Debug: Calculated CellLeft - " & cellLeft
                    
                    ' Center the image in Column F
                    .Top = cellTop
                    .Left = cellLeft
                End With
                Debug.Print "Debug: Image inserted successfully"
            Else
                Debug.Print "Debug: Invalid aspect ratio"
            End If
        Else
            Debug.Print "Debug: Image URL is empty"
        End If
    Next cell
End Sub

Function GetImageAspectRatio(imgPath As String) As Double
    On Error Resume Next
    Dim img As Picture
    Set img = ActiveSheet.Pictures.Insert(imgPath)
    
    If Err.Number = 0 Then
        Dim aspectRatio As Double
        aspectRatio = img.ShapeRange.width / img.ShapeRange.height
        img.Delete  ' Delete the inserted image
        GetImageAspectRatio = aspectRatio
    Else
        GetImageAspectRatio = 0
    End If
    On Error GoTo 0
End Function

 

 

 


So I think either both of these codes are missing something or I have some strange setting in excel that is causing the cell shift.

Can anyone help figure out what is going on? Setting, code error or both?

  • Which version of Excel are you using? Have you considered the IMAGE function?

3 Replies

  • JKPieterse's avatar
    JKPieterse
    Silver Contributor
    Which version of Excel are you using? Have you considered the IMAGE function?
    • Jay_Rabe's avatar
      Jay_Rabe
      Copper Contributor

      JKPieterse 
      I did not know about =IMAGE.  It seems to do exactly what I need it to do and is so simple.  Thank you!


      Do you know if  =image pastes an actual image and does not pull from the url again?  I'd like to only pull the images once from the url if possible.

      I'm using 365, version 2401.

      • JKPieterse's avatar
        JKPieterse
        Silver Contributor
        I think the images are cached, but I'm not 100% sure.

Resources