KenCriss
Active Member
- Joined
- Jun 6, 2005
- Messages
- 326
Hello coders - I am using the following code to search for files. ListFiles() does a great job if you don't want to search subdirectories. However, if the user does want to search subdirectories (bRecursive = TRUE) there is an issue whereby
I am wanting to let the user pick a file type (ex *.pdf, *.xlsx) but when the user inputs anything other than *.* for the Sub Directory search, it only comes back with the number of directories and does not find any files. Would anyone be able to see the source of my problems here? Many thanks!
I am wanting to let the user pick a file type (ex *.pdf, *.xlsx) but when the user inputs anything other than *.* for the Sub Directory search, it only comes back with the number of directories and does not find any files. Would anyone be able to see the source of my problems here? Many thanks!
Code:
Option Explicit
Public myExtension As String
Public t As Date
Public r As Long
Public NumDirs As Long
Sub ListFiles()
Dim Directory As String
Dim f As String
Dim Filesize As Double
Dim msg As String
Dim bDoRecursive As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select a location containing the files you want to list"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
Else
Directory = .SelectedItems(1) & "\"
End If
End With
r = 1
MacroEnter
t = Now()
If MsgBox("Include Sub Folders ?", vbYesNo) = vbYes Then
bDoRecursive = True
Else
bDoRecursive = False
End If
msg = "Enter File name and Extension" & vbLf & "following wild" & _
" cards can be used" & vbLf & "* # ?" & vbCrLf & "Examples = '*.*' for all files or '*.pdf' for all PDF files"
myExtension = Application.InputBox(msg)
If (myExtension = "False") + (myExtension = "") Then Exit Sub
If bDoRecursive = True Then
Workbooks.Add ' create a new workbook for the file list
Call RecursiveDir(Directory)
MsgBox "Done!" & vbCrLf & "Directories found = " & NumDirs & vbCrLf & "Files found = " & r - 1 & vbCrLf & "Elapsed time = " & Format(Now() - t, "hh:mm:ss"), vbOKOnly, "Test"
GoTo DoneFiles
End If
' Insert headers
Workbooks.Add ' create a new workbook for the file list
ActiveSheet.Name = "FileResults"
Cells(r, 1) = "Files in " & Directory
Cells(r, 2) = "Size"
Cells(r, 3) = "Date/Time"
Range("A1:C1").Font.Bold = True
' Get first file
f = Dir(Directory & myExtension, vbReadOnly + vbHidden + vbSystem)
Do While f <> ""
r = r + 1
Cells(r, 1) = f
'adjust for filesize > 2 gigabytes
Filesize = FileLen(Directory & f)
If Filesize < 0 Then Filesize = Filesize + 4294967296#
Cells(r, 2) = Filesize
Cells(r, 3) = FileDateTime(Directory & f)
Application.StatusBar = "Found file named " & f
' Get next file
f = Dir
Loop
MsgBox "Done!" & vbCrLf & "Files found = " & r - 1 & vbCrLf & "Elapsed time = " & Format(Now() - t, "hh:mm:ss"), vbOKOnly, "Test"
DoneFiles:
Range("a2").Select
ActiveWindow.FreezePanes = True
Cells.EntireColumn.AutoFit
MacroExit
End Sub
Public Sub RecursiveDir(ByVal CurrDir As String)
Dim Dirs() As String
Dim FileName As String
Dim PathAndName As String
Dim i As Long
Dim Filesize As Double
' Make sure path ends in backslash
If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"
' Put column headings on active sheet
ActiveSheet.Name = "FileResults"
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "Size"
Cells(1, 4) = "Date/Time"
Range("A1:D1").Font.Bold = True
' Get files
On Error Resume Next
FileName = Dir(CurrDir & myExtension, vbDirectory)
Do While Len(FileName) <> 0
If Left(FileName, 1) <> "." Then 'Current dir
PathAndName = CurrDir & FileName
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
'store found directories
ReDim Preserve Dirs(0 To NumDirs) As String
Dirs(NumDirs) = PathAndName
NumDirs = NumDirs + 1
Else
r = r + 1
'Write the path and file to the sheet
Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName
'adjust for filesize > 2 gigabytes
Filesize = FileLen(PathAndName)
If Filesize < 0 Then Filesize = Filesize + 4294967296#
Cells(WorksheetFunction.CountA(Range("C:C")) + 1, 3) = Filesize
Cells(WorksheetFunction.CountA(Range("D:D")) + 1, 4) = FileDateTime(PathAndName)
End If
End If
FileName = Dir()
Loop
' Process the found directories, recursively
For i = 0 To NumDirs - 1
RecursiveDir Dirs(i)
Next i
End Sub
Sub MacroEnter()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
End Sub
Sub MacroExit()
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub