Macro to search for pictures in subfolders

Question

I will realy appreciate your help on this issue. I'm quite new with macro.

The macro that I'm using is inserting a picture in Excel column A cells by taking the file name reference from the column B cells.

I have the following macro that works just fine if I know the subfolder were to search for the picture that I need but I don't know how to do it to search in all subfolders of Z:\mfs\PictureLibrary.

Here is the macro :

   Sub Picture()
   Dim picname As String

   Dim pasteAt As Integer
   Dim lThisRow As Long

lThisRow = 2

Do While (Cells(lThisRow, 2) <> "")


    pasteAt = lThisRow
    Cells(pasteAt, 1).Select 'This is where picture will be inserted


    picname = Cells(lThisRow, 2) 'This is the picture name

    present = Dir("Z:\mfs\PictureLibrary\Codello A14 Transfer\" & picname & ".jpg")

    If present <> "" Then

        ActiveSheet.Pictures.Insert("Z:\mfs\PictureLibrary\Codello A14 Transfer\" & picname & ".jpg").Select 'Path to where pictures are stored
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' This resizes the picture
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''
        With Selection
        '.Left = Range("A2").Left
        '.Top = Range("A2").Top
        .Left = Cells(pasteAt, 1).Left
        .Top = Cells(pasteAt, 1).Top

        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 55#
        .ShapeRange.Width = 40#
        .ShapeRange.Rotation = 0#
        End With



    Else
        Cells(pasteAt, 1) = ""
    End If

       lThisRow = lThisRow + 1
Loop

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub

score 0 · Answer 1 · answered Jun 17 '15 at 19:20

0

Please, check the example below, it iterates through subfolders and search for your file, you just have to fit it in your code:

Dim FileSystem As Object
Const mainFolder As String = "Z:\mfs\PictureLibrary\Codello A14 Transfer\"

Sub YourProblem()

    Dim filePath As String
    filePath = Find("pictureName.jpg")
    MsgBox filePath

End Sub

Function Find(picName As String) As String

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    Find = FindPicture(FileSystem.GetFolder(mainFolder), picName)

End Function

Function FindPicture(innerFolder, picName As String) As String

    Dim pictureFound As String
    pictureFound = Dir(innerFolder & "\" & picName)

    If Len(Trim(pictureFound)) > 0 Then
        FindPicture = innerFolder & "\" & pictureFound
        Exit Function
    Else
        Dim subFolder
        For Each subFolder In innerFolder.SubFolders

            pictureFound = FindPicture(subFolder, picName)
            If Len(Trim(pictureFound)) > 0 Then
                FindPicture = pictureFound
                Exit Function
            End If
        Next
    End If

End Function

answered Jun 17 '15 at 19:20

Abe

274
1
11

Thank you so much for answering me so quickly but, honestly, I have no idea what I must do with the codes you give me and where between my codes to insert it. I guess that saying that I'm new with macro is not quite accurate. I'm more like I just found out that exists and have an idea about what can do. – Crina Jun 17 '15 at 20:18
Try this: paste the two first lines of my code example before all code you have on your module, paste the two `Function` I have coded at the end of your module, and forget about the `Sub`. Change your code `picname = Cells(lThisRow, 2)` to `picname = Cells(lThisRow, 2) & ".jpg"` and where you have `present = Dir(...)`, change to `present = Find(picname)`. Finally, change `ActiveSheet.Pictures.Insert(...)` to `ActiveSheet.Pictures.Insert(present)`. This might do the trick. – Abe Jun 17 '15 at 20:30
Yes. This whay is working just that it takes some time. Thank you so so much. You've made my day :) – Crina Jun 17 '15 at 21:01
Np! Yea, since it is accessing some system features, you can expect it to take some time, also, the more subfolders you have, more time you will need to check them all. If this answer fits your need, please mark it as accepted ;). – Abe Jun 17 '15 at 21:10

Macro to search for pictures in subfolders

1 Answers1