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

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!