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!
