dsoderstrom
asked on
Listing folders using vba
I would like to use VBA to list all of the folders and subfolders under a specified folder on my computer. Can anyone show me how to code this?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
You suggestion worked perfectly for what I was doing. My goal was to find duplicate files within a folder tree. Once I ran the command you suggested and imported the data into an Access table I was able to query the information I needed. Thank You
If you are going after the files, you can change or remove the /ad parameter on the dir command.
Jim.
Function FindAllMDBs(strPath As String) As Integer
Dim strFindStr As String
Dim lngFileSize As Long
Dim intNumFiles As Integer
Dim intNumDirs As Integer
On Error GoTo Error_FindAllMDBs
Set dbCur = CurrentDb()
Set rstFiles = dbCur.OpenRecordset("tblMD
strFindStr = "*.MDB"
lngFileSize = FindFiles(strPath, strFindStr, intNumFiles, intNumDirs)
FindAllMDBs = True
Exit_FindAllMDBs:
If Not rstFiles Is Nothing Then
rstFiles.Close
Set rstFiles = Nothing
End If
If Not dbCur Is Nothing Then
Set dbCur = Nothing
End If
Exit Function
Error_FindAllMDBs:
MsgBox "Error: " & Err.Number & " - " & Err.Description, , "Unexpected Error"
FindAllMDBs = False
Resume Exit_FindAllMDBs
End Function
Function FindFiles(path As String, SearchStr As String, FileCount As Integer, DirCount As Integer) As Long
Dim FileName As String ' Walking filename variable.
Dim DirName As String ' SubDirectory Name.
Dim dirNames() As String ' Buffer for directory name entries.
Dim nDir As Integer ' Number of directories in this path.
Dim i As Integer ' For-loop counter.
Dim db As Database
Dim strVersion As String
Dim strErrorMsg As String
' Set error trap.
On Error GoTo sysFileERR
' Make sure we have a properly terminated path.
If Right(path, 1) <> "\" Then path = path & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden) ' Even if hidden.
Do While Len(DirName) > 0
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
sysFileERRCont:
End If
DirName = Dir() ' Get next subdirectory.
Loop
' Search through this directory and sum file sizes.
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFiles = FindFiles + FileLen(path & FileName)
FileCount = FileCount + 1
On Error Resume Next
Err = 0
Set db = Workspaces(0).OpenDatabase
If Err = 0 Then
strErrorMsg = ""
strVersion = db.Version
Else
Select Case Err
Case 3033
strVersion = ""
strErrorMsg = "No permission for MDB"
Case 3045
strVersion = ""
strErrorMsg = "Database in use."
Case 3031
strVersion = ""
strErrorMsg = "Password protected MDB"
Case 3343
strVersion = "4.0"
strErrorMsg = ""
Case Else
GoTo UnexpectedOpenError
End Select
End If
rstFiles.AddNew
rstFiles![Name] = FileName
rstFiles![Location] = path
rstFiles![DateModified] = FileDateTime(path & FileName)
rstFiles![Version] = strVersion
rstFiles![ErrorMsg] = strErrorMsg
rstFiles.Update
'Debug.Print path & FileName & vbTab & FileDateTime(path & FileName) & vbTab & db.version ' Include Modified Date
db.Close
Set db = Nothing
' Get next file
FileName = Dir()
Wend
' If there are sub-directories..
If nDir > 0 Then
' Recursively walk into them
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", SearchStr, FileCount, DirCount)
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont ' Known issue with pagefile.sys
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , "Unexpected Error"
Resume AbortFunction
End If
UnexpectedOpenError:
MsgBox "Error: " & Err.Number & " - " & Err.Description, , "Unexpected Error"
GoTo AbortFunction
End Function