Last two days I had a hard time trying to figure out why my vba macro failed to position pictures in cells.
My goal was to add pictures of products loaded from external JPG files (previously resized to 64×64) to each row, so user can easily distinguish the product she is working with just by glancing.
To emmbed pictures into the file I used Shapes.AddPicture method. To properly position it within the cell I passed Left and Top paramters.
Set shp = targetSheet.Shapes.AddPicture( _ fileName:=picPath, LinkToFile:=False, SaveWithDocument:=True _ , Left:=picLeft, Top:=picTop, Width:=-1, Height:=-1)
By passing -1 to Width and Height parameters the picture preserved it’s original dimensions.
But no matter what parameters I passed to AddPicture method each next product was placed with a little offset from the top of the target cell. And each next product it was misplaced a little bit further to the bottom.
I was almost out of ideas when I understood that the zoom of the target sheet was set to 80, as it’s more was required for this report.
After setting it to 100 in vba macro before inserting pictures and then resetting it back to 80 I was able to properly position images within cells.
So here’s a little chunk of code that inserts pictures for me.
appWorkbooks.OpenText fileName:=m_picsDataFilePath, TextQualifier:=xlNone, DataType:=xlDelimited, Tab:=True, _ FieldInfo:=Array( _ Array(1, xlGeneralFormat_), Array(2, xlGeneralFormat_), Array(3, xlGeneralFormat_) _ ) Set picsWorkbook = appWorkbooks(GetFName(m_picsDataFilePath)) targetSheet.Activate ActiveWindow.Zoom = 100 plog ("Insert pictures") picColumnIdx = m_targetDataMapper.GetIdx("V41") Set workRange = targetSheet.Cells(1, picColumnIdx) workRange.EntireColumn.NumberFormat = "0" picLeft = workRange.Left + 2 Set workRange = Nothing Set sourceSheet = picsWorkbook.Sheets(1) rowIdx = templateRow + 1 maxRowIdx = templateRow + sourceRowCount picRowIdx = 2 Do While (rowIdx <= maxRowIdx) ' And rowIdx < 100 picPath = sourceSheet.Cells(picRowIdx, 1).value picTop = 0 picTop = targetSheet.Cells(rowIdx, picColumnIdx).Top + 2 ' plog (CStr(picLeft) & " " & CStr(picTop)) If "" <> picPath Then ' picWidth = sourceSheet.Cells(picRowIdx, 2).value ' picHeight = sourceSheet.Cells(picRowIdx, 3).value Set shp = targetSheet.Shapes.AddPicture( _ fileName:=picPath, LinkToFile:=False, SaveWithDocument:=True _ , Left:=picLeft, Top:=picTop, Width:=-1, Height:=-1) shp.Placement = xlMoveAndSize Set shp = Nothing Else Set shp = targetSheet.Shapes.AddShape(msoShapeRectangle, _ picLeft, picTop, 65, 68) With shp.Fill .ForeColor.RGB = RGB(255, 255, 255) .BackColor.RGB = RGB(255, 255, 255) End With shp.Line.Visible = msoFalse shp.Placement = xlMoveAndSize Set shp = Nothing End If picRowIdx = picRowIdx + 1 rowIdx = rowIdx + 1 Loop picsWorkbook.Close SaveChanges:=False Set picsWorkbook = Nothing ActiveWindow.Zoom = 80
Note the addition of the white rectangular shape for each missing picture to fully cover the cell. It solves the problem of stacking pictures when somebody filters products.
I was able to solve this problem, but I wonder how many other quirks does Excel have.