Public PathPicture As String
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures
pictureNameColumn = "B"
picturePasteColumn = "H"
pictureRow = 2 'starts from this row
'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running
Application.ScreenUpdating = False
pathForPicture = "C:\Bloemen\"
'loop till last row
Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "B") 'This is the picture name
'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
Call Enlist_Directories(pathForPicture, pictureName & ".jpg")
If (Dir(PathPicture) <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(PathPicture).Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop
Application.ScreenUpdating = True
End Sub
Public Sub Enlist_Directories(strPath As String, sPicture As String)
Dim strFldrList() As String
Dim lngArrayMax, x As Long
lngArrayMax = 0
strFn = Dir(strPath & "*.*", 23)
While strFn <> ""
If strFn <> "." And strFn <> ".." Then
If (GetAttr(strPath & strFn) And vbDirectory) = vbDirectory Then
lngArrayMax = lngArrayMax + 1
ReDim Preserve strFldrList(lngArrayMax)
strFldrList(lngArrayMax) = strPath & strFn & "\"
Else
If UCase(strPath & strFn) = UCase(strPath & sPicture) Then PathPicture = strPath & strFn: Exit Sub
End If
End If
strFn = Dir()
Wend
If lngArrayMax <> 0 Then
For x = 1 To lngArrayMax
Call Enlist_Directories(strFldrList(x), sPicture)
Next
End If
End Sub
