How can i improve my function for handling alternative to Application.FileSearch VBA

Question

I have decided to attempt a UDF around alternative to Application.FileSearch. I assume a few locations where a file COULD be located. Solutions on the internet tend to assum

Answer 1

You talk about efficiency, do you mean readability? Or efficiency in terms of processing power required? The first example is easy enough to read, and change, so I would say that it's readable, but if you know that a file is in, say, one of 3 locations, it would be better to dir each location separately, as in the second example.

Regarding the following, it relies on the file in question being inside the "HostFolder" that you specify, so effectively the more precise you can be, the more efficient it will be. For example, using the following will be increasingly more efficient:

C:\

C:\Reports

C:\Reports\May

Credit to @Rich for his answer here:

Loop Through All Subfolders Using VBA

Sub MainBeast()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "C:\mypath\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If File.Name = "Name.xlsm" Then
            Workbooks.Open (Folder.Path & "\" & "Name.xlsm"), UpdateLinks:=False
            Workbooks("Name.xlsm").Activate
            Exit Sub
        End If
    Next
End Sub

I should say though, that this will just open the first instance that it finds of the file named "name.xlsm". You need to make modifications if you want to deal with multiple files, although this should be easily possible by storing the potential paths with the Path.FileDateTime and opening the most recent.

Regarding the second, if you have a shortlist of places to check, then I would use the code below, this is more efficient, but if the file is not in the right location, then it won't work:

sub MainBeast()
    if fileExists("C:\" & "Name.xlsm") then Workbooks.Open ("C:\" & "Name.xlsm"), UpdateLinks:=False
    if fileExists("C:\locA\" & "Name.xlsm") then Workbooks.Open ("C:\locA\" & "Name.xlsm"), UpdateLinks:=False
    if fileExists("C:\locB\" & "Name.xlsm") then Workbooks.Open ("C:\locB\" & "Name.xlsm"), UpdateLinks:=False
End Sub
Function FileExists(ByVal FullPath As String) As Boolean
If dir(FullPath) <> "" Then
    FileExists = True
Else
    FileExists = False
End If
End Function

Answer 2

Option 1 - RecentFiles

Although I have to agree with @TimWilliams' assessment that "long-winded" doesn't mean "inefficient", if the file is accessed frequently enough you should be able to find it in the .RecentFiles collection:

Public Function FindFile() As String
    Dim x As Variant
    For Each x In Application.RecentFiles
        If x.Name Like "*File Name.xlsm" Then
            FindFile = x.Name
            Exit Function
        End If
    Next x
End Function

Keep in mind that this is a complete hack solution, and I would never use it for anything resembling production code, because the fall-back method if it fails would be similar to either what you posted or @tompreston's answer.

---

Option 2 - WMI

Again, this boils down to what your definition of "efficient" is. You can query the filesystem with WMI, but this is likely to be horrendously slow in processing time, especially if you don't have everything indexed:

Public Function FindFile() As String
    With CreateObject("winmgmts:root/CIMV2")
        Dim results As Object, result As Object, query As String
        query = "SELECT TOP 1 * FROM Cim_DataFile WHERE Filename = 'File Name' AND Extension = 'xlsm'"
        Set results = .ExecQuery(query)
        For Each result In results
            FindFile = result.Path & "File Name.xlsm"
            Exit Function
        Next
    End With
End Function

You can probably speed this up by "suggesting" directories with an added query filter along the lines of "AND Path IN ('C:\X\X\', 'C:\X\X\X\')", but at that point you're better off with your original solution from the question.

---

The correct answer is going to tend toward the "long winded", as that avoids having frustrated end users constantly contacting you when they get strange error dialogs because you chose terse coding over robust code. "Efficiency" isn't a just measure of how much you have to type. I'd consider a solution that I never have to provide support for or maintain incredibly efficient.

Answer 3

Whilst I admire the file handling capabilities of Excel VBA, one does miss the trick of shelling to the command line, we can use the DIR command line tool to print directory results and then process these.

Further we can do this asynchronously, that is to say we can shell the process and then go off and do other work (or just allow user to have a responsive session) and when results are ready we process them.

The DIR Command Line Tool

The key switch to the DIR command line tool is /S which means process recursively through subdirectories. See dir switches for documentation. Also it is critical that one pipes the output to a file so it can be processed by the code. So the command line (on my computer) looks like this

dir k:\testDir\someFile.txt /s > c:\temp\dir.txt

where my k drive is set up with some test data and the temp directory is where we write the results file (your temp directory maybe different).

But if we are shelling a process in code then we need some extra logic; we need to run cmd.exe and then pass it the above command line to process. We can find where cmd.exe lives by using the comspec environment variable. We also need to pass the /S /C flags to cmd.exe here is documentation for that cmd switches

C:\WINDOWS\system32\cmd.exe /S /C dir k:\testDir\someFile.txt /s > c:\temp\dir.txt

So we need to run the above command line, I will present two implementations, one synchronous and the other asynchronous.

Synchronous Implementation

The key code is in SyncLaunchShelledCmdDir which shells the command line then calls Windows API for a handle on the shelled process and then wait for it to complete with WaitForSingleObject then we call a subroutine ProcessResultsFile to do the string handling and parsing of results.

modSyncShellDir.bas

Option Explicit

Private Const msRESULTSFILE As String = "c:\temp\dirSync.txt"
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Const INFINITE = &HFFFF

Private Sub UnitTestSyncLaunchShelledCmdDir()
    SyncLaunchShelledCmdDir "k:\testDir\", "someFile.txt"
End Sub

Private Sub SyncSampleProcessResults(ByVal vResults As Variant)
    '*** YOUR CODE GOES HERE
    Dim vLoop As Variant
    For Each vLoop In vResults
        Debug.Print vLoop
    Next
End Sub

Private Sub SyncLaunchShelledCmdDir(ByVal sTopLevelDirectory As String, ByVal sFileNameToLookFor As String)
    Debug.Assert Right$(sTopLevelDirectory, 1) = "\"


    Dim sCmd As String
    sCmd = VBA.Environ$("comspec") & " /S /C"
    Dim lShelledCmdDir As Long
    lShelledCmdDir = VBA.Shell(sCmd & "  dir " & sTopLevelDirectory & sFileNameToLookFor & " /s > " & msRESULTSFILE)

    Dim hProc As Long
    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, lShelledCmdDir)

    If hProc <> 0 Then
        WaitForSingleObject hProc, INFINITE

        Dim sFileContents As String
        sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall

        Dim vResults As Variant
        vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)
        SyncSampleProcessResults vResults

    End If
    CloseHandle hProc

End Sub

Private Function ProcessResultsFile(ByVal sFileContents As String, ByVal sFileNameToLookFor As String) As Variant

    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")

    Dim lFindFileName As Long
    lFindFileName = VBA.InStr(1, sFileContents, sFileNameToLookFor, vbTextCompare)

    While lFindFileName > 0
        '* found something so step back and get previous "Directory of"

        Dim lPreviousDirectoryOfPos As Long
        lPreviousDirectoryOfPos = VBA.InStrRev(sFileContents, "Directory of ", lFindFileName + 1, vbTextCompare)

        Dim lDirectoryStringBeginningPos As Long
        lDirectoryStringBeginningPos = lPreviousDirectoryOfPos + Len("Directory of ")

        Dim lNextLineFeedAfterPreviousDirectoryOfPos As Long
        lNextLineFeedAfterPreviousDirectoryOfPos = VBA.InStr(lDirectoryStringBeginningPos, sFileContents, vbNewLine, vbTextCompare)
        If lNextLineFeedAfterPreviousDirectoryOfPos > 0 Then
        Dim sSlice As String
        sSlice = Mid(sFileContents, lDirectoryStringBeginningPos, lNextLineFeedAfterPreviousDirectoryOfPos - lDirectoryStringBeginningPos)


        dic.Add sSlice, 0

        End If

        lFindFileName = VBA.InStr(lFindFileName + 1, sFileContents, sFileNameToLookFor, vbTextCompare)

    Wend

    ProcessResultsFile = dic.keys


End Function

Private Sub UnitTestProcessResultsFile()
    Dim sFileNameToLookFor As String
    sFileNameToLookFor = "someFile.txt"

    Dim sFileContents As String
    sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall
    Dim vResults As Variant
    vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)

End Sub

modAsyncShellDir.bas
This implementation is asynchronous, we reuse as much code as possible but to make this work we need to give ourselves some module level variables, also we need to use Application.OnTime and Application.Run to handle the polling and the callback. This time we do not wait for the process to finish but poll its exit code using the Windows API call GetExitCodeProcess

Option Explicit

Private mlShelledCmdDir As Double
Private msFileNameToLookFor As String
Private msCallbackFunction As String

Private Const msRESULTSFILE As String = "c:\temp\dirAsync.txt"
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal lnghProcess As Long, lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Sub UnitTestAsyncLaunchShelledCmdDir()
    AsyncLaunchShelledCmdDir "k:\testDir\", "someFile.txt", "AsyncSampleProcessResults"
End Sub


Private Sub AsyncSampleProcessResults(ByVal vResults As Variant)
    '*** YOUR CODE GOES HERE
    Dim vLoop As Variant
    For Each vLoop In vResults
        Debug.Print vLoop
    Next
End Sub

Private Sub AsyncLaunchShelledCmdDir(ByVal sTopLevelDirectory As String, ByVal sFileNameToLookFor As String, ByVal sCallbackFunction As String)
    Debug.Assert Right$(sTopLevelDirectory, 1) = "\"
    msFileNameToLookFor = sFileNameToLookFor
    msCallbackFunction = sCallbackFunction
    Dim sCmd As String
    sCmd = VBA.Environ$("comspec") & " /S /C"
    mlShelledCmdDir = VBA.Shell(sCmd & "  dir " & sTopLevelDirectory & sFileNameToLookFor & " /s > " & msRESULTSFILE)


    Application.OnTime Now() + CDate("00:00:01"), "PollLaunchShelledCmdDir"
End Sub

Private Sub PollLaunchShelledCmdDir()
    If Not IsLaunchShelledCmdDirRunning Then
        Dim sFileContents As String
        sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall

        Dim vResults As Variant
        vResults = ProcessResultsFile(sFileContents, msFileNameToLookFor)
        Application.Run msCallbackFunction, vResults
    Else
        Application.OnTime Now() + CDate("00:00:01"), "PollLaunchShelledCmdDir"
    End If
End Sub


Private Function IsLaunchShelledCmdDirRunning() As Boolean
    Dim hProc As Long
    Dim lExitCode As Long
    Dim lRet As Long

    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, mlShelledCmdDir)
    If hProc <> 0 Then
        GetExitCodeProcess hProc, lExitCode
        IsLaunchShelledCmdDirRunning = (lExitCode <> 0)
    End If
    CloseHandle hProc

End Function




Private Function ProcessResultsFile(ByVal sFileContents As String, ByVal sFileNameToLookFor As String) As Variant

    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")

    Dim lFindFileName As Long
    lFindFileName = VBA.InStr(1, sFileContents, sFileNameToLookFor, vbTextCompare)

    While lFindFileName > 0
        '* found something so step back and get previous "Directory of"

        Dim lPreviousDirectoryOfPos As Long
        lPreviousDirectoryOfPos = VBA.InStrRev(sFileContents, "Directory of ", lFindFileName + 1, vbTextCompare)

        Dim lDirectoryStringBeginningPos As Long
        lDirectoryStringBeginningPos = lPreviousDirectoryOfPos + Len("Directory of ")

        Dim lNextLineFeedAfterPreviousDirectoryOfPos As Long
        lNextLineFeedAfterPreviousDirectoryOfPos = VBA.InStr(lDirectoryStringBeginningPos, sFileContents, vbNewLine, vbTextCompare)
        If lNextLineFeedAfterPreviousDirectoryOfPos > 0 Then
            Dim sSlice As String
            sSlice = Mid(sFileContents, lDirectoryStringBeginningPos, lNextLineFeedAfterPreviousDirectoryOfPos - lDirectoryStringBeginningPos)


            dic.Add sSlice, 0

        End If

        lFindFileName = VBA.InStr(lFindFileName + 1, sFileContents, sFileNameToLookFor, vbTextCompare)

    Wend

    ProcessResultsFile = dic.keys
End Function


Private Sub UnitTestProcessResultsFile()
    Dim sFileNameToLookFor As String
    sFileNameToLookFor = "someFile.txt"

    Dim sFileContents As String
    sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall
    Dim vResults As Variant
    vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)

End Sub

I hope these are not too long-winded. I think it is nice to shell out and get another process to do some work, especially if one can do this asynchronously. This is a very useful technique that can make Excel VBA applications very responsive. This is particularly true for notoriously lengthy processes like disc activity.

Thanks for setting a bounty!

Answer 4

All, the solution presented below is built from Tom Prestons answer. I have given credits where due.

Key parts to the code:

• A check was added to see if the reference to Microsoft Scripting Run Time was already enabled or not. This is essential when running code that requires the scripting. This code will be run on a hosts computer and they more often that not will have no reference enabled and thus the code will fail. N.B Credit to Is there a code to turn on Microsoft Scripting Runtime Library? @Vasily. The code was modified to "AddFromFile" as oppose to from GUID. This however assumed that all host computers will contain the scrunn dll in the same location

---

• The HostFolder is very high level. From there, a fair amount of sub folders have to be searched through but unfortunately i need it at this level. For anyone reading this, if you know with 100% certainty that a client will not move the key file to a location OUTSIDE of the HostFolder, make it even more specific to speed up run time
• Code optimisation through "Application." (In fairness it made little difference for some reason, without it t akes 40 seconds and with it takes c32 seconds)
• Replaced the Workbooks.Open commands with File.Name, as opposed to actually referencing the name of the file
• All variables declared globally (much cleaner)

CODE:

Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Dim Ref As Object, CheckRefEnabled%
Sub FindFile()
HostFolder = "F:\x\x\"

CheckRefEnabled = 0
With ThisWorkbook
    For Each Ref In .VBProject.References
        If Ref.Name = "Scripting" Then
            CheckRefEnabled = 1
            Exit For
        End If
    Next Ref
    If CheckRefEnabled = 0 Then
        .VBProject.References.AddFromFile ("C:\Windows\System32\scrrun.dll")
    End If
End With

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)

End Sub
Sub DoFolder(Folder)

With Application
    .EnableEvents = False
    .DisplayStatusBar = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If File.Name = "y.xlsm" Then
            Workbooks.Open (Folder.path & "\" & File.Name), UpdateLinks:=False
            Workbooks(File.Name).Activate
            Exit Sub
        End If
    Next

With Application
    .EnableEvents = True
    .DisplayStatusBar = True
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

Thank you all for your contributions, the Stack Overflow community is excellent!