When exporting the modules I tend to create a temp directory which means I have very many VBA module on my machine. Sometimes I like to go browse code I have already written for re-use. It would be nice to get a list of every VBA module on a drive. This is today's post.
I've seen people write code to iterate through folders and files many times but this is tedious and actually not asynchronous or multi-threadable. I like to use the command DIR *.* /s > c:\temp\cdrive_star_dot_star.txt to scan the whole hard drive into a text file, this is great for one part of the long running task as can be run in its own separate window but we'll still need code to loop through the piped output file.
The code will parse the directory output file and write to a sheet, but we add some value in that we look for .bas and .cls files, i.e. VBA files, but we ensure they are genuine VBA files by reading the first line and checking. The results are written to Sheet1 periodically, the code uses DoEvents to stay responsive so you can begin browsing the results whilst the code is running. Enjoy!
Option Explicit
Private m_fso As New Scripting.FileSystemObject
Private msDIR As String
Sub Test()
'* my blog does not like angle brackets - grrrr!
msDIR = " " & Chr$(60) & "DIR" & Chr$(62) & " "
'* ASSUMES YOU HAVE DONE c:\dir *.* /s > c:\temp\cdrive_star_dot_star.txt
Sheet1.Cells.Clear
Dim sPipedOutputPath As String
sPipedOutputPath = "c:\temp\cdrive_star_dot_star.txt"
'sPipedOutputPath = "c:\temp\cdrive_test.txt"
sPipedOutputPath = "c:\temp\cdrive_test2.txt"
Dim dicLongListResults As Scripting.Dictionary
Debug.Assert m_fso.FileExists(sPipedOutputPath)
ReadDirForwardSlashS sPipedOutputPath, dicLongListResults
Debug.Assert dicLongListResults.Count = _
Sheet1.Cells(1, 1).CurrentRegion.Rows.Count
End Sub
Sub PasteResults(ByVal dicLongListResults As Scripting.Dictionary, _
ByVal lResultIndex As Long)
If dicLongListResults.Count > 0 Then
Dim vResults As Variant
vResults = Application.Transpose(dicLongListResults.Keys)
Dim rngOrigin As Excel.Range
Set rngOrigin = Sheet1.Cells(lResultIndex, 1)
Debug.Assert IsEmpty(rngOrigin.Value)
rngOrigin.Resize(dicLongListResults.Count) = vResults
dicLongListResults.RemoveAll
End If
End Sub
Function ReadDirForwardSlashS(ByVal sPipedOutputPath As String, _
ByRef pdicLongListResults As Scripting.Dictionary)
Dim lResultIndex As Long: lResultIndex = 1
Dim lSavedResultIndex As Long: lSavedResultIndex = 1
Dim dicInterimResults As Scripting.Dictionary
Set dicInterimResults = New Scripting.Dictionary
If m_fso.FileExists(sPipedOutputPath) Then
Dim txtIn As Scripting.TextStream
Set txtIn = m_fso.OpenTextFile(sPipedOutputPath)
Set pdicLongListResults = New Scripting.Dictionary
Dim lLineNumber As Long
lLineNumber = 0
Dim sLine As String
sLine = txtIn.ReadLine
While Not txtIn.AtEndOfStream
DoEvents
lLineNumber = lLineNumber + 1
Dim bIsFileHeader As Boolean
bIsFileHeader = IsFileHeader(sLine, lLineNumber)
Dim bIsBlankLine As Boolean
bIsBlankLine = IsBlankLine(sLine)
Dim sDirectory As String
Dim bIsDirectoryHeader As Boolean
bIsDirectoryHeader = IsDirectoryHeader(sLine, sDirectory)
Dim bIsTrailerLine As Boolean
bIsTrailerLine = IsTrailerLine(sLine)
If bIsTrailerLine Then
PasteResults dicInterimResults, lSavedResultIndex
lSavedResultIndex = lResultIndex
End If
Dim bIsEntryLine As Boolean
bIsEntryLine = (Not bIsFileHeader) And (Not bIsDirectoryHeader) And _
(Not bIsTrailerLine) And (Not bIsBlankLine)
Dim bIsFileLine As Boolean
bIsFileLine = IsFileLine(bIsEntryLine, sLine)
If bIsFileLine Then
Dim sFileName As String
sFileName = Trim$(Mid$(sLine, 37))
Dim sLastFourChars As String
sLastFourChars = Right$(sFileName, 4)
Dim lFileTypeFound As Long
lFileTypeFound = InStr(1, "|.bas|.cls|", "|" & sLastFourChars & _
"|", vbTextCompare)
If lFileTypeFound > 0 Then
Dim lFileType As Long
lFileType = (lFileTypeFound - 1) / 5
Dim sFullPath As String
sFullPath = m_fso.BuildPath(sDirectory, sFileName)
Debug.Assert m_fso.FileExists(sFullPath)
Dim txtFileContents As Scripting.TextStream
Set txtFileContents = m_fso.OpenTextFile(sFullPath)
If Not txtFileContents.AtEndOfStream Then
Dim sTopLine As String
sTopLine = txtFileContents.ReadLine
Dim bIsVBAFile As Boolean
If lFileType = 0 Then
bIsVBAFile = (Left$(sTopLine, 19) = "Attribute VB_Name =")
Else
bIsVBAFile = (Left$(sTopLine, 17) = "VERSION 1.0 CLASS")
End If
txtFileContents.Close
Set txtFileContents = Nothing
If bIsVBAFile Then
pdicLongListResults.Add sFullPath, lFileType
dicInterimResults.Add sFullPath, lFileType
lResultIndex = lResultIndex + 1
End If
End If
'Stop
End If
End If
sLine = txtIn.ReadLine
Wend
txtIn.Close
Set txtIn = Nothing
End If
End Function
Function IsTrailerLine(ByVal sLine As String) As Boolean
If (VBA.InStr(1, sLine, "File(s)", vbTextCompare) > 0) Then
IsTrailerLine = True
End If
End Function
Function IsBlankLine(ByVal sLine As String) As Boolean
IsBlankLine = (Len(Trim(sLine)) = 0)
End Function
Function IsFileLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
If bIsEntryLine Then
If (VBA.InStr(1, sLine, msDIR, vbTextCompare) = 0) Then
IsFileLine = True
End If
End If
End Function
Function IsSubdirectoryLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
If bIsEntryLine Then
If (VBA.InStr(1, sLine, msDIR, vbTextCompare) > 0) Then
IsSubdirectoryLine = True
End If
End If
End Function
Function IsDirectoryHeader(ByVal sLine As String, ByRef psDirectory As String) As Boolean
If VBA.InStr(1, sLine, " Directory of ", vbTextCompare) > 0 Then
psDirectory = Trim(Mid$(sLine, 15))
IsDirectoryHeader = True
End If
End Function
Function IsFileHeader(ByVal sLine As String, ByVal lLineNumber As Long) As Boolean
If lLineNumber <= 2 Then
IsFileHeader = (VBA.InStr(1, sLine, " Volume ", vbTextCompare) > 0)
End If
End Function
No comments:
Post a Comment