Finally got around to creating my own version. (Thanks to Bob and Ken whose code i pinched.)
It's a little bit messy, so any suggestions to tidy it up?
[vba]Option Explicit
Option Compare Text
Dim i As Long
Dim LookingFor As String
Dim FileSearch()
Sub DoFileSearch()
Dim FSO As Object
Dim Pth As String
Dim X As Long
'Set options
Pth = BrowseForFolder()
'Pth = BrowseForFolder(MyDocuments)
'Pth = BrowseForFolder("C:\") 'Processing C:\ can take a long time
LookingFor = "" 'Process filter if required
i = 0 'Counter if required
Cells.Clear 'Clear old results if required
ReDim FileSearch(6, 1000000)
Set FSO = CreateObject("Scripting.FileSystemobject")
Call ProcessFolder(FSO, Pth, True)
If i = 0 Then
MsgBox "No files found"
Exit Sub
Else
ReDim Preserve FileSearch(6, i - 1)
End If
'Process found files
Cells(1, 1).Resize(, 7) = Array("Path", "FileName", "Last Accessed", "Last Modified", "Created", "Type", "Size")
Cells(2, 1).Resize(i, 7) = Application.Transpose(FileSearch)
Set FSO = Nothing
End Sub
Private Function ProcessFolder( _
ByRef FSO As Object, _
ByVal Foldername As String, _
Optional ByVal Init As Boolean)
Dim Fldr As Object
Dim SubFldr As Object
Dim File As Object
Set Fldr = FSO.GetFolder(Foldername)
'Process head folder once only
If Init = True Then
For Each File In Fldr.Files
ProcessFiles Fldr, File
Next File
End If
On Error Resume Next
For Each SubFldr In Fldr.SubFolders
'Handle restricted folders e.g Recylce Bin
If Not Err = 70 Then
For Each File In SubFldr.Files
ProcessFiles SubFldr, File
Next File
Call ProcessFolder(FSO, SubFldr.Path)
End If
Next SubFldr
Set File = Nothing
Set SubFldr = Nothing
Set Fldr = Nothing
End Function
'Add files to array
Sub ProcessFiles(Fld, f)
If f.Name Like "*" & LookingFor Then
FileSearch(0, i) = Fld.Path
FileSearch(1, i) = f.Name
FileSearch(2, i) = f.DateLastAccessed
FileSearch(3, i) = f.DateLastModified
FileSearch(4, i) = f.DateCreated
FileSearch(5, i) = f.Type
FileSearch(6, i) = f.Size
i = i + 1
End If
End Sub
Function MyDocuments() As String
Dim wshShell As Object
Set wshShell = CreateObject("WScript.Shell")
MyDocuments = wshShell.Specialfolders("MyDocuments")
Set wshShell = Nothing
End Function
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
[/vba]
Reply With Quote
Originally Posted by mdmackillop
