Dynamically Load Picture Images To A Worksheet
Worksheets that reference product numbers can be enhanced to include images of the product. The code below illustrates the techique of image retrieval, "right-sizing" the image, changing the row height to fit the image, and then inserting the image into the worksheet with padding to enhance the appearance of the worksheet.
Program Code
Option Explicit
Sub InsertPicturesIntoExcelWorksheet()
Dim lngNumberOfDetailRows As Long
Dim lngPictureRow As Long
Dim strFileName As String
Dim strFullFileName As String
Dim strSuccess As String
' *********************************************
' Determine The Number Of Rows
' *********************************************
lngNumberOfDetailRows = ActiveSheet.UsedRange.Rows.Count
lngNumberOfDetailRows = lngNumberOfDetailRows + ActiveSheet.UsedRange.Row - 1
' *********************************************
' On Error, Flag The Image As Not Found
' *********************************************
On Error GoTo ImageNotFound
' *********************************************
' Loop Through All Lines of the Worksheet
' *********************************************
For lngPictureRow = 2 To lngNumberOfDetailRows
strFileName = Cells(lngPictureRow, 1).Value
If strFileName = "" Then
strFileName = "DoesNotExist"
End If
' *********************************************
' Acquire The Image Name
' *********************************************
strFullFileName = "C:\SampleImages\" & strFileName
strSuccess = "Y"
' *********************************************
' Retrieve The Image And Place At Upper Corner
' *********************************************
ActiveSheet.Pictures.Insert(strFullFileName).Select
' ***************************************************************
' If Image Is Found, Then:
' (1) Set Ratio Of Image Height To Width To Be Locked
' (2) Set Image Height To Fit Within Worksheet Max Height
' (3) Excel Will Adjust the Image Width To Proper Ratio
' (4) Cut The Image
' (5) Adjust The Target Row Height To Fit The Image With Padding
' (6) Paste The Image In The Correct Row And Column Location
' (7) Add Padding To The Top and Left Of The Image
' ***************************************************************
If strSuccess = "Y" Then
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 72#
Selection.Cut
Rows(lngPictureRow).RowHeight = 80
Cells(lngPictureRow, 5).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementTop 3
Selection.ShapeRange.IncrementLeft 3
Else
Rows(lngPictureRow).RowHeight = 12.75
End If
Next lngPictureRow
Cells(1, 1).Select
Exit Sub
ImageNotFound:
strSuccess = "N"
Resume Next
End Sub
