FileSystemObject and Subfolders

[faberk]

I have a requirement to perform mass changes to the footers of .xls files. Using the filesystemobect, i have managed to display the names of the folders immediately subordinate to my main path. I would like to loop through all folders. There are many levels. How do I access the many levels below my seed path?

[matthewspatrick]

Here is some old code of mine that will recurse through subfolders for you. Has some evidence of my old bad habits, like using the Select method for no good reason, but it works ;)



Option Explicit

' Code based on procedures found at:
' http://www.exceltip.com/show_tip/Files,_Workbook,_and_Worksheets_in_VBA/ (http://www.exceltip.com/show_tip/Files,_Workbook,_and_Worksheets_in_VBA/)
' List_files_in_a_folder_with_Microsoft_Scripting_Runtime_using_VBA_in_Micros oft_Excel/446.html

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long
Dim x As Long
Dim pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If

End Function

Sub DoListFilesInFolder()

Dim CheckPath As String
Dim Msg As Byte
Dim Drilldown As Boolean
Dim Extensions As String

CheckPath = GetDirectory()

If CheckPath = "" Then
MsgBox "No folder was selected. Procedure aborted.", vbExclamation, "StaffSmart Add-In"
Exit Sub
End If
Extensions = InputBox("Please enter the allowed file extensions (blank or all for 'all file types')", _
"Look for File Extensions", "All")
Extensions = UCase(IIf(Extensions = "", "All", Extensions))

Msg = MsgBox("Do you want to list all files in descendant folders, too?", _
vbInformation + vbYesNo, "Drill-Down")
If Msg = vbYes Then Drilldown = True Else Drilldown = False

Workbooks.Add ' create a new workbook for the file list
ActiveWindow.Zoom = 75
' add headers
With Range("A1")
.Formula = "Folder contents: "
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Folder:"
Range("B3").Formula = "File Name:"
Range("C3").Formula = "File Size:"
Range("D3").Formula = "File Type:"
Range("E3").Formula = "Date Created:"
Range("F3").Formula = "Date Last Accessed:"
Range("G3").Formula = "Date Last Modified:"
Range("H3").Formula = "Attributes:"
Range("A3:H3").Font.Bold = True
ListFilesInFolder CheckPath, Drilldown, Extensions
' list all files included subfolders

Range("a4").Select
ActiveWindow.FreezePanes = True
Range("a3").Select
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4"), _
Order2:=xlAscending, Header:=xlYes
Range("H3").AddComment
With Range("H3").Comment
.Visible = False
.Text Text:="The file attribute can have any of the following values " & _
"or any logical combination of the following values:" & Chr(10) & _
"0 = Normal file. No attributes are set. " & Chr(10) & _
"1 = Read-only file" & Chr(10) & _
"2 = Hidden file" & Chr(10) & _
"4 = System file" & Chr(10) & ""
.Text Text:=Chr(10) & "8 = Disk drive volume label " & Chr(10) & _
"16 = Folder or directory " & Chr(10) & _
"32 = File changed since last backup " & Chr(10) & _
"64 = Link or shortcut " & Chr(10) & _
"128 = Compressed file" & Chr(10) & Chr(10) & _
"For example, 3 = Read-only and Hidden", Start:=200
.Shape.Height = 200
.Shape.Width = 144
End With

Range("a1") = Range("a1").Value & CheckPath & IIf(Drilldown, " (with descendants)", _
" (without descendants)")
Range("a3").Select

ActiveWindow.LargeScroll Up:=100

MsgBox "Done"

End Sub

Private Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean, Ext As String)

' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True

Dim FSO As Object 'Scripting.FileSystemObject
Dim SourceFolder As Object 'Scripting.Folder
Dim SubFolder As Object 'Scripting.Folder
Dim FileItem As Object 'Scripting.File
Dim r As Long

Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
If Ext = "ALL" Or InStr(1, Ext, Mid(FileItem.Name, InStrRev(FileItem.Name, ".", -1) + 1)) > 0 Then
' display file properties
Cells(r, 1).Formula = FileItem.ParentFolder.path '& FileItem.Name
Cells(r, 2).Formula = FileItem.Name
Cells(r, 3).Formula = FileItem.Size
Cells(r, 4).Formula = FileItem.Type
Cells(r, 5).Formula = FileItem.DateCreated
Cells(r, 6).Formula = FileItem.DateLastAccessed
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = FileItem.Attributes
r = r + 1 ' next row number
End If
Next FileItem

' If "descendant" folders also get their files listed, then sub calls itself recursively

If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.path, True, Ext
Next SubFolder
End If

Columns("A:H").AutoFit

Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing

End Sub

[malik641]

Hey faberk, Welcome to VBAX! :hi:

In addition to mathewspatrick's post (ya beat me to it, buddy :) )....

The method you're looking for is called recursive code. It's code that calls itself over and over through all subfolders and works its way from the bottom up.

The fastest method I've seen is using the Dir() function. Matt (mvidas) from this forum was kind enough to give this code here. Just call it sending the Main directory (top level) and a string array:

Function ReturnAllFilesUsingDir(ByVal vPath As String, ByRef vsArray() As String) As Boolean
Dim tempStr As String, vDirs() As String, Cnt As Long, dirCnt As Long

If Len(vsArray(0)) = 0 Then
Cnt = 0
Else
Cnt = UBound(vsArray) + 1
End If
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
On Error GoTo BadDir
tempStr = Dir(vPath, 31)

Do Until Len(tempStr) = 0
If Asc(tempStr) <> 46 Then
If GetAttr(vPath & tempStr) And vbDirectory Then
ReDim Preserve vDirs(dirCnt)
vDirs(dirCnt) = tempStr
dirCnt = dirCnt + 1
End If
BadDirGo:
End If
tempStr = Dir
SkipDir:
Loop
On Error GoTo BadFile
tempStr = Dir(vPath, 15)
Do Until Len(tempStr) = 0
ReDim Preserve vsArray(Cnt)
vsArray(Cnt) = vPath & tempStr
Cnt = Cnt + 1
tempStr = Dir
Loop
'Debug.Print Cnt
BadFileGo:
On Error GoTo 0
If dirCnt > 0 Then
For dirCnt = 0 To UBound(vDirs)
If Len(Dir(vPath & vDirs(dirCnt))) = 0 Then
ReturnAllFilesUsingDir vPath & vDirs(dirCnt), vsArray
End If
Next
End If
Exit Function
BadDir:
If tempStr = "pagefile.sys" Or tempStr = "???" Then
' Debug.Print "DIR: Skipping: " & vPath & tempStr
Resume BadDirGo
ElseIf Err.Number = 52 Then 'or err.number=5 then
' Debug.Print "No read rights: " & vPath & tempStr
Resume SkipDir
End If
Debug.Print "Error with DIR (BadDir): " & Err.Number & " - " & Err.Description
Debug.Print " vPath: " & vPath
Debug.Print " tempStr: " & tempStr
Exit Function
BadFile:
If Err.Number = 52 Then 'or err.number=5 then
' Debug.Print "No read rights: " & vPath & tempStr
Else
Debug.Print "Error with DIR (BadFile): " & Err.Number & " - " & Err.Description
Debug.Print " vPath: " & vPath
Debug.Print " tempStr: " & tempStr
End If
Resume BadFileGo
End Function
And call it like so:
Sub Test()
' How to call ReturnAllFilesUsingDir
Dim vsArray() As String
Dim vPath As String
Dim i As Long

vPath = "C:\"

Call ReturnAllFilesUsingDir(vPath, vsArray())

If Not IsError(vsArray(0)) Then
For i = 0 To UBound(vsArray())
If vsArray(i) Like "*.xls" Then
' Open the workbook and change what you need
End If
Next
End If
End Sub
This is what I use to return all files in a given directory where I have to move down all subdirectories. The IF statement "If Not IsError(vsArray(0)) Then" line still kinda bugs me because I don't think it's an accurate way to check if no files were found (although it's unlikely you would call the function with an empty directory), but it works for me like that (when no files are found). I hope you can find this equally useful for what you're trying to do :thumb

[faberk]

Thank you gentlemen! Very interesting! :SHOCKED:

[tstom]

Joseph. I could not get your code to run. Subscript error.

Faberk. Here is an example using the FileSystemObject. It will return all xls files from a root folder (and subfolders) as a fileobject array.


Option Explicit

Dim Files() As Object

Sub Example()
Dim Root As Object, f As Object
ReDim Files(0)
Set Root = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Documents and Settings\Tom\dESKTOP")
GetFiles Root
For Each f In Root.Files
If f.Type = "Microsoft Excel Worksheet" Then
Set Files(UBound(Files)) = f
ReDim Preserve Files(UBound(Files) + 1)
End If
Next
ReDim Preserve Files(UBound(Files) - 1)
Test
End Sub

Sub Test()
Dim x As Long

For x = LBound(Files) To UBound(Files)
Debug.Print Files(x).Path
Debug.Print Files(x).DateLastModified
Debug.Print Files(x).Size
Debug.Print "-------------------------------------------------------"
Next
End Sub

Sub GetFiles(Root As Object)
Dim f As Object, sf As Object
For Each sf In Root.SubFolders
GetFiles sf
For Each f In sf.Files
If f.Type = "Microsoft Excel Worksheet" Then
Set Files(UBound(Files)) = f
ReDim Preserve Files(UBound(Files) + 1)
End If
Next
Next
End Sub

[johnske]

Also using FileSystemObject...
Option Explicit

Sub TryThis()
ShowAllFilesAllFoldersIn ("C:\Windows\Desktop")
End Sub

Sub ShowAllFilesAllFoldersIn(FolderPath)

Dim FolderFound As Object, File As Object

For Each FolderFound In CreateObject("Scripting.FileSystemObject") _
.GetFolder(FolderPath).SubFolders

Debug.Print FolderFound.Name

If Not FolderFound.Files.Count = 0 Then
For Each File In FolderFound.Files
'do what you want with the file here
Debug.Print vbTab & File.Name
Next
End If

Next

End Sub


If you want this to apply only to .xls files, you can use somethong like this...

Sub ShowAllFilesAllFoldersIn(FolderPath)

Dim FolderFound As Object, File As Object

For Each FolderFound In CreateObject("Scripting.FileSystemObject") _
.GetFolder(FolderPath).SubFolders

Debug.Print FolderFound.Name

If Not FolderFound.Files.Count = 0 Then

For Each File In FolderFound.Files
If File.Name Like "*.xls" Then
'do what you want with the file here
Debug.Print vbTab & File.Name
End If
Next

End If
Next

End Sub

[tstom]

Johnske. There is no recursion in your code. It will only search second level folders and no further. Also any files in the root are not accounted for...

[johnske]

Johnske. There is no recursion in your code. It will only search second level folders and no further. Also any files in the root are not accounted for...Hmm, yeh you're right tom - just shows what happens if you do things in a rush & don't think them out properly :devil2:

[tstom]

Well... I don't know about you but I have never been able to get a grip on recursive techniques. For some people it's easy and others it just doesn't click...

[malik641]

Well... I don't know about you but I have never been able to get a grip on recursive techniques. For some people it's easy and others it just doesn't click...
I hear ya. I'm still having trouble with it....but I feel like I'm starting to understand it :)

Also, my apologies on the error, I forgot to add this line:

ReDim vsArray(0)

So it looks like:
Sub Test()
' How to call ReturnAllFilesUsingDir
Dim vsArray() As String
Dim vPath As String
Dim i As Long

vPath = "C:\Test Files\"

ReDim vsArray(0)

Call ReturnAllFilesUsingDir(vPath, vsArray())

If Not IsError(vsArray(0)) Then
For i = 0 To UBound(vsArray())
If vsArray(i) Like "*.xls" Then
' Open the workbook and change what you need
Debug.Print "Yes"
End If
Next
End If
End Sub

Sorry about that!