Recursive Directory Listings with VBA

Question

0.00/5 (No votes)

See more:

Hello everyone, I'm writing some code for a senior seminar as a business major, however I am not a strong programmer. The project involves me writing code in VBA that will go through a file directory, and produce line by line in the cells in excel the file paths for each file in the prescribed listing.
This is what I have so far, it creates a new page, however, so far I am not getting any output, but it throws no errors. It is currently enabled to only pull other .xls files for testing's sake.

If it helps at all, the file structure in question looks something like the following

'Documents' --> 'Ian's Stuff' --> 'Ian's Stuff' --> 'Business Seminar in IT' --> 'Business Seminar in IT Notes'

Option Explicit

Sub FullDir()
ActiveWorkbook.Sheets.Add
GetFiles "c:\documents\", ".xls"
End Sub

Sub GetFiles(strRootDir As String, Optional strType As String)

Dim strDirName As String
Dim bTypeMatch As Boolean
Dim colDirs As Collection
Dim lDirCounter As Long
Dim lIndex As Long

Set colDirs = New Collection
colDirs.Add strRootDir
lDirCounter = 1
lIndex = 2

'check for sub directories and make a recursive call to the lowest level dirs first

Do While lDirCounter <= colDirs.Count
strRootDir = colDirs(lDirCounter)
strDirName = Dir(strRootDir, vbDirectory + vbNormal)
Do While strDirName <> ""
If strDirName <> "." And strDirName <> ".." Then
If (GetAttr(strRootDir & strDirName) And vbDirectory) = vbDirectory Then

'add to the directories collection so that this will be done later

colDirs.Add strRootDir & strDirName & "\"
Else

'we found a normal file

bTypeMatch = False
If strType = "*.*" Then
bTypeMatch = True
ElseIf UCase(Right(strDirName, Len(strType))) = UCase(strType) Then
bTypeMatch = True
End If
If bTypeMatch = True Then
'we found a valid file

Cells(lIndex, 1) = strRootDir & strDirName
lIndex = lIndex + 1
End If
End If
End If
strDirName = Dir
Loop
lDirCounter = lDirCounter + 1
Loop
End Sub

Posted 20-Feb-13 6:20am

iGuy91

Updated 20-Feb-13 6:25am

Richard C Bishop

v2

Add a Solution

2 solutions

Solution 1

Below is a VBScript example of directory recursion that I developed. I put this file in my SENDTO directory so that I can right-click on a directory name and select this script file from the Send to context menu.

Option Explicit

'
' CreateDirectoryListing.VBS
' ===========================
'    Mike Meinz
'    11 Janury 2004
'
'
Const TemporaryFolder = 2
CONST THEFILENAME="_DirectoryListing.TXT"
Const MinWidth = 36
'
Dim objTempFolder 
Dim objArgs
Dim objLogFSO
Dim objLogFile
Dim wshShell
Dim strFileName
'
Sub ProcessItem(ByVal objItem, ByVal intMax)
Dim strAttr
strAttr = Space(4)
If objItem.Attributes And 1 Then
    strAttr = "R   " ' ReadOnly
End If
If objItem.Attributes And 2 Then
    strAttr=LEFT(strAttr, 1) & "H  " ' Hidden
End If
If objItem.Attributes And 4 Then
    strAttr=LEFT(strAttr, 2) & "S " ' System
End If
If objItem.Attributes And 32 Then
    strAttr=LEFT(strAttr,3) &  "A" ' Archive
End If
Call LogIt( _
    Left(objItem.Name & Space(intMax), intMax) & vbTab & _
    objItem.DateCreated & vbTab & _
    objItem.DateLastModified & vbTab & _
    objItem.Size & vbTab & _
    strAttr & vbTab & _
    objItem.Type, True)
End Sub
'
Sub ProcessFiles(ByVal strFolderSpec)
Dim objFSO
Dim objFolder
Dim objFileCollection
Dim objFolderCollection
Dim objItem
Dim objSubFolder
Dim strAttr
Dim intMax
Call LogIt(strFolderSpec, True)
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Err.Clear
Set objFolder = objFSO.GetFolder(strFolderSpec)
If Err.Number = 0 Then
    On Error GoTo 0
    Set objFileCollection = objFolder.Files
    For Each objItem In objFileCollection
        ' Determine Maximum FileName size
        If intMax < Len(objItem.Name) Then
            intMax = Len(objItem.Name)
        End If
    Next
    If intMax < MinWidth Then 
        intMax = MinWidth ' Minimum Size is MinWidth
    End If
    For Each objItem In objFileCollection
        Call ProcessItem(objItem, intMax)
    Next
    Call LogIt("", True)
    Set objFolderCollection = objFolder.SubFolders
    For Each objSubFolder In objFolderCollection
        Call ProcessFiles(objSubFolder.Path)
    Next
    Set objItem = Nothing
    Set objFileCollection = Nothing
    Set objSubFolder = Nothing
    Set objFolderCollection = Nothing
Else
    MsgBox "GetFolder Error" & vbNewLine & _
        Err.Description & "(" & Err.Number & ")" & vbNewLine & _
        strFolderSpec, vbCritical
    On Error GoTo 0
End If
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub

Sub LogIt(ByVal strMessage, ByVal bNewLine)
If bNewLine Then
    objLogFile.WriteLine strMessage
Else
    objLogFile.Write strMessage
End If
End Sub
'**********************************************************************
' Starts Here
'
Set objArgs = WScript.Arguments
Set objLogFSO = CreateObject("Scripting.FileSystemObject")
Set objTempFolder = objLogFSO.GetSpecialFolder(TemporaryFolder)
Set objLogFile = objTempFolder.CreateTextFile(THEFILENAME,True,True)
strFileName = objTempFolder.path & "\" & THEFILENAME
Call LogIt(Left("FileName" + Space(MinWidth), MinWidth) & vbTab & _
    LEFT("DateCreated"+SPACE(20),20) & vbTab & _
    LEFT("DateLastModified"+SPACE(20),20) & vbTab & _
    "Size" & vbTab & _
    "Attr" & vbTab & _
    "FileType", True)
Call ProcessFiles(objArgs(0))
objLogFile.Close
Set objLogFile = Nothing
Set wshShell = CreateObject("WScript.Shell")
wshShell.CurrentDirectory=objTempFolder.path
wshShell.Run ("Notepad.exe " & strFileName)
Set objTempFolder=Nothing
Set objLogFSO = Nothing
Set wshShell = Nothing
Set objArgs = Nothing
'
' Ends  here
'

Posted 20-Feb-13 7:19am

Mike Meinz

Comments

Maciej Los 20-Feb-13 16:29pm

VBS <> VBA!

Mike Meinz 20-Feb-13 16:31pm

Maciej Los - See Solution 2 - VBS easily migrated to VBA

Add a Solution

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Mike Meinz · Accepted Answer · 2013-02-20T10:19:00

I modified the code from Solution 1 to search for ".xls" and to add to an Excel worksheet. The code below can be copied and pasted into an Excel Macro (ThisWorkBook).

Option Explicit
'
Dim lIndex
'
Private Sub ProcessItem(ByVal objItem, ByVal strFolderSpec As String)
'
' Adds a filename to the spreadsheet
'
' File Attributes are here in case you want to use them for something
'
Dim strAttr
strAttr = Space(4)
If objItem.Attributes And 1 Then
    strAttr = "R   " ' ReadOnly
End If
If objItem.Attributes And 2 Then
    strAttr = Left(strAttr, 1) & "H  " ' Hidden
End If
If objItem.Attributes And 4 Then
    strAttr = Left(strAttr, 2) & "S " ' System
End If
If objItem.Attributes And 32 Then
    strAttr = Left(strAttr, 3) & "A" ' Archive
End If
'
Cells(lIndex, 1) = strFolderSpec & "\" & objItem.Name
lIndex = lIndex + 1
'
End Sub
'
Private Sub ProcessFiles(ByVal strFolderSpec As String, ByVal strFilter As String)
'
' Processes directories and files in directories
'
Dim objFSO
Dim objFolder
Dim objFileCollection
Dim objFolderCollection
Dim objItem
Dim objSubFolder
Dim strAttr
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Err.Clear
Set objFolder = objFSO.GetFolder(strFolderSpec)
If Err.Number = 0 Then
    Err.Clear
    Set objFileCollection = objFolder.Files
    If Err.Number = 0 Then
        Err.Clear
        For Each objItem In objFileCollection
            If Not (IsEmpty(objItem)) Then ' Handles fact that some subfolders are not real subfolders
                'Debug.Print objItem.Name
                '
                ' Select only those that exactly match the filter
                '
                If LCase(Right(objItem.Name, Len(strFilter))) = LCase(strFilter) Then
                     Call ProcessItem(objItem, strFolderSpec)
                End If
            End If
        Next
    Else
        Debug.Print Err.Number & " " & Err.Message & " " & objFolder.Path
    End If
    On Error Resume Next
    Err.Clear
    Set objFolderCollection = objFolder.SubFolders
    If Err.Number = 0 Then
        Err.Clear
        For Each objSubFolder In objFolderCollection
            If Not (IsEmpty(objSubFolder)) Then ' Handles fact that some subfolders are not real subfolders
                'Debug.Print objSubFolder.Path
                '
                ' Process a subfolder
                '
                Call ProcessFiles(objSubFolder.Path, strFilter)
            End If
        Next
    Else
        Debug.Print Err.Number & " " & Err.Message & " " & objFolder.Path
    End If
    Set objItem = Nothing
    Set objFileCollection = Nothing
    Set objSubFolder = Nothing
    Set objFolderCollection = Nothing
Else
    MsgBox "GetFolder Error" & vbNewLine & _
        Err.Description & "(" & Err.Number & ")" & vbNewLine & _
        strFolderSpec, vbCritical
    On Error GoTo 0
End If
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub

Public Sub FullDir()
' Starts Here
'
lIndex = 2
ActiveWorkbook.Sheets.Add
Call ProcessFiles("C:\Users\<yourusername>\Documents", ".xls")
'
' Ends  here
'
End Sub

Recursive Directory Listings with VBA

2 solutions

Solution 2

Solution 1

Add your solution here

Preview 0

Recursive Directory Listings with VBA

2 solutions

Solution 2

Solution 1

Add your solution here

Preview 0

Existing Members

...or Join us