Use filtered DIR rather than FSO.Name Like to speed up code

[vbavirgin]

Hi,

I have 2 functions and a sub that search through a folder and its subfolders for jpegs matching a naming covention.

It works fine but I understand that using a filtered DIR approach would make this much quicker. The code is below.

Can anyone help?

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function


Function picInsert2(folder As String, articleCode As String, material As String, colour As String, row1 As Integer, column1 As Integer)
Dim objFSO As Object
Dim objFolder, objSubfolder As Object
Dim objFile As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Enter the folder where the images are stored
Set objFolder = objFSO.GetFolder(folder) 'choose folder using GetFolder function


For Each objFile In objFolder.Files

On Error Resume Next
   If objFile.Name Like ("*" & LCase(articleCode) & "*" & LCase(material) & "*" & LCase(colour) & "*jpg") Or objFile.Name Like ("*" & UCase(articleCode) & "*" & UCase(material) & "*" & UCase(colour) & "*.jpg") Then
    With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50)
            .Fill.UserPicture objFile
            .Left = ActiveSheet.Cells(row1, column1).Left
            .Top = ActiveSheet.Cells(row1, column1).Top
            .Height = ActiveSheet.Cells(row1, column1).Height
            .Width = ActiveSheet.Cells(row1, column1).Width
        End With
    End If
Next objFile

    If objFolder.Subfolders.Count > 0 Then
        For Each objSubfolder In objFolder.Subfolders
            Call picInsert2(objSubfolder.Path, articleCode, material, colour, row1, column1)
        Next objSubfolder
    End If
    
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objSubfolder = Nothing
    Set objFile = Nothing

End Function


Sub PrintPicFile2()
Dim i As Integer
Dim articleCode As String, colour As String, folder As String, material As String
Dim lRow As Long
Dim fdr As String

lRow = Cells(Rows.Count, 1).End(xlUp).row
fdr = GetFolder()

For i = 3 To lRow
    folder = fdr
    articleCode = ActiveSheet.Cells(i, 1) ' to change the column that the style name is in change the 1 = A, 2 = B ...
    material = ActiveSheet.Cells(i, 2) ' to change the column that the material is in change the 1 = A, 2 = B ...
    colour = ActiveSheet.Cells(i, 3) ' to change the column that the colour is in change the 1 = A, 2 = B ...
    Call picInsert2(folder, articleCode, material, colour, i, 4) ' to change the column where the image goes change the 3 = C...
    Rows(i).Select

Next i

End Sub

 

[John_w]

The fastest way of searching for matching file names in a folder and its subfolders is the DOS DIR command. You can call this using WScript.Shell - for example see https://www.mrexcel.com/forum/excel...folder-subfolder-post5140361.html#post5140361.

 

[vbavirgin]

Thanks John. This is really useful. I have been testing this and I can get a message box to list files but I have no idea how to use this with my code.
I'll keep at it!

 

[John_w]

Your code is slower than it could be because it runs the recursive folder search for every row. It would be faster to put all *.jpg file names into an array and search that. This uses the WScript.Shell approach:

    Dim files As Variant   
    fdr = GetFolder()    
    files = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & """" & fdr & "\*.jpg" & """" & " /b /s").StdOut.ReadAll, vbCrLf)

Now, for each row, loop through the files array (which contains full file names including paths) looking for the matching file name.

 

[vbavirgin]

Hi John,

Thank you for the leg up!. I rewrote the code and it worked! Comparing:
FSO took 2mins 47secs
DIR took 55 secs!

Could you check the below to see if it is efficient?

Thank you.

Sub PrintPicDIR()
Dim StartTime As Double
Dim MinutesElapsed As String
Dim files As Variant
Dim i As Long
Dim frow As Integer
Dim lrow As Long


StartTime = Timer


lrow = Cells(Rows.Count, 1).End(xlUp).row


fdr = GetFolder()
files = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & """" & fdr & "\*.jpg" & """" & " /b /s").StdOut.ReadAll, vbCrLf)


Call Delete 'calls a sub to delete any existing textboxes


For frow = 3 To lrow


    For i = LBound(files) To UBound(files)


    If files(i) Like ("*" & LCase(ActiveSheet.Cells(frow, 1)) & "*" & LCase(ActiveSheet.Cells(frow, 2)) & "*" & LCase(ActiveSheet.Cells(frow, 3)) & "*") Or files(i) Like ("*" & UCase(ActiveSheet.Cells(frow, 1)) & "*" & UCase(ActiveSheet.Cells(frow, 2)) & "*" & UCase(ActiveSheet.Cells(frow, 3)) & "*") Then
    With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50)
            .Fill.UserPicture files(i)
            .Left = ActiveSheet.Cells(frow, 4).Left
            .Top = ActiveSheet.Cells(frow, 4).Top
            .Height = ActiveSheet.Cells(frow, 4).Height
            .Width = ActiveSheet.Cells(frow, 4).Width
        End With
    End If


    Next i
    'MsgBox Join(files, vbLf)
    Rows(frow).Select
    Call ShapeSelection ' calls sub to select shapes that appear each row
    Call Space ' calls a sub that spaces the slected shapes horizontally


Next frow


MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Image search took: " & MinutesElapsed, vbInformation


End Sub

 

[John_w]

The code looks OK, though I don't think you need LCase and UCase if you use LCase for the file name as well, and ignoring the folder path:

    Dim fileName As String
    fileName = Mid(files(i), InStrRev(files(i), "\") + 1)
    If LCase(fileName) Like LCase("*" & ActiveSheet.Cells(frow, 1) & "*" & ActiveSheet.Cells(frow, 2) & "*" & ActiveSheet.Cells(frow, 3) & "*") Then

Also, I think you'll find that the last element of the files array is "", so loop from LBound(files) To UBound(files) - 1.

 

[Fazza]

consider too moving the "StartTime = Timer" line from the top of the code to immediately after the "fdr = GetFolder()" line

 

[vbavirgin]

Thank you both for your help. Much appreciated.