A VBA that inserts an image into the actual cell

[bizzyizzy215]

I have VBA that inserts many pictures, but they need to be inserted (really embedded) at the end of a row for a referenced cell. I have the logic down, but I believe my syntax for the Insert is incorrect. Any help would be appreciated. My aspect ratio logic is good and picture positioning is good.

Sub ImportPicturesFromColumn()
    Dim ws As Worksheet
    Dim picturePath As String
    Dim pic As Picture
    Dim picWidth As Double
    Dim picHeight As Double
    Dim maxWidth As Double
    Dim maxHeight As Double
    Dim aspectRatio As Double
    Dim cell As Range
    Dim startCell As Range
    Dim targetCell As Range
    
    ' Set the worksheet to "XX-ExcelExport"
    Set ws = ThisWorkbook.Sheets("XX-ExcelExport")
    
    ' Set the maximum width and height for the picture
    maxWidth = 420 ' Set to your desired max width
    maxHeight = 420 ' Set to your desired max height
    
    ' Set the starting cell for the list of picture paths
    Set startCell = ws.Range("K4") ' Start reading paths from cell K4
    
    ' Loop through each cell in the column until an empty cell is found
    For Each cell In ws.Range(startCell, ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp))
        picturePath = cell.Value
                
        ' Stop processing if a blank cell is encountered
        If picturePath = "" Then
            Exit For
        End If
        
        ' Add the picture to the worksheet
    [COLOR=rgb(226, 80, 65)]    Set pic = ws.Pictures.Insert(picturePath)[/COLOR]
                
        ' Get the original dimensions of the picture
        picWidth = pic.Width
        picHeight = pic.Height
        
        ' Calculate the aspect ratio
        aspectRatio = picWidth / picHeight
        
        ' Adjust the picture size to maintain aspect ratio
        If picWidth > maxWidth Or picHeight > maxHeight Then
            If (maxWidth / maxHeight) > aspectRatio Then
                picHeight = maxHeight
                picWidth = maxHeight * aspectRatio
            Else
                picWidth = maxWidth
                picHeight = maxWidth / aspectRatio
            End If
        End If
        
        ' Set the new dimensions
        pic.Width = picWidth
        pic.Height = picHeight
        
        ' Determine the target cell for the picture
        Set targetCell = ws.Cells(cell.Row, "Q") ' Place picture in column Q, same row as file path
        
        ' Position the picture within the target cell
        pic.Top = targetCell.Top
        pic.Left = targetCell.Left
        
        ' Optionally, resize the cell to fit the picture
        targetCell.RowHeight = Application.Max(targetCell.RowHeight, pic.Height)
        targetCell.ColumnWidth = Application.Max(targetCell.ColumnWidth, pic.Width / 5.7) ' Adjust column width
    Next cell
End Sub

 

[saboh12617]

Hello, why not using Range.InsertPictureInCell or Shape.PlacePictureInCell since you are using office365? It will really stuck the image in the cell and you just have to resize it.