Forum Discussion
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
- JKPieterseSilver ContributorWhich version of Excel are you using? Have you considered the IMAGE function?
- Jay_RabeCopper 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.- JKPieterseSilver ContributorI think the images are cached, but I'm not 100% sure.