Modifing Excel Macro VBA - inserting pictures from all subfolders after giving basic location.

Highlighted
Occasional Visitor

Hello,

 

I am having trouble with editing this macro. Below you can see the one i use for getting pictures from a location. Now i have to change it so it also searches for pictures in catalogues withing the catalogue I give direction to. There is many of them and generated in different ways, so I can't predict their names.

Can you help me add a part of code where it looks also in all subfolders, even 3 levels deeper?

Sub PictureInAColumnNo1()

Dim Xrange, Xcell As Range
Dim PhotoPath, PhotoDirPath, Model As String
Dim Cellpicture As Shape
Dim PhotoObject As Object

ColumnInp = InputBox("A", "B")

If ColumnInp = "" Then
Exit Sub
Else
ColumnMod = Mid(ActiveCell.Address, InStr(ActiveCell.Address, "$") + 1, InStr(2, ActiveCell.Address, "$") - 2)
Set Xrange = ActiveSheet.Range(ColumnInp & ActiveCell.Row & ":" & ColumnInp & "40000")
End If

For Each Xcell In Xrange

Xcell.Select
rownum = ActiveCell.Row
On Error Resume Next
If ActiveSheet.Range(ColumnMod & rownum).Value = "" Then
Exit For

End If

Model = ActiveSheet.Range(ColumnMod & rownum).Value
PhotoPath = "MY DIRECTORY\Blablabla\" & Model & "#1" & ".jpg"
If (PhotoPath) Then
Set PhotoObject = CreateObject("WIA.Imagefile")
PhotoObject.LoadFile PhotoPath
Xcell.ColumnWidth = 20
Xcell.RowHeight = 110
Set Cellpicture = Application.ActiveSheet.Shapes.AddPicture(PhotoPath, True, True, Columns(Xcell.Column).Left + 5, Rows(Xcell.Row).Top + 5, -1, -1)
Cellpicture.Width = 100
Else
ActiveCell.Value = "Photo missing"
End If

Next

End Sub

 

 

0 Replies