Option Explicit
'/===========================================/
' Sub Purpose:
' History:
' 07/15/2000 added hyperlink
' 07/17/2000 added filename filter
' 07/20/2000 added # files found info & criteria info
' 07/27/2000 added extension as separate column
' 08/03/2000 changed # files found to 'count' formula
' 10/23/2000 add status bar 'Wait' message
' 01/18/2007 change to FileDialog property
' 05/14/2009 change from FileSearch to recursive DIR
' for 2007 comparability (Dir Recursive
' basic concept from MrExcel.com)
'
'/===========================================/
'
Public Sub ListFilesToWorksheet()
Dim blnSubFolders As Boolean
Dim dblLastRow As Long
Dim R As Integer, x As Integer
Dim y As Integer, iWorksheets As Integer
Dim i As Long, j As Long, k As Long
Dim fso As Object
Dim Msg As String, strDirectory As String, strPath As String
Dim strResultsTableName As String, strFileName As String
Dim strWorksheetName As String
Dim strArr() As String
Dim strName As String
Dim strFileNameFilter As String, strDefaultMatch As String
Dim strExtension As String, strFileBoxDesc As String
Dim strMessage_Wait1 As String, strMessage_Wait2 As String
Dim varSubFolders As Variant, varAnswer As String
On Error Resume Next
'- - - - V A R I A B L E S - - - - - - - - -
strResultsTableName = "File_Listing"
strDefaultMatch = "*.*"
R = 1
i = 1
blnSubFolders = False
strMessage_Wait1 = _
"Please wait while search is in progress..."
strMessage_Wait2 = _
"Please wait while formatting is completed..."
ReDim strArr(1 To 65536, 1 To 3)
'- - - - - - - - - - - - - - - - - - - - - -
strFileNameFilter = _
InputBox("Ex: *.* with find all files" & vbCr & _
" blank will find all Office files" & vbCr & _
" *.xls will find all Excel files" & vbCr & _
" G*.doc will find all Word files beginning with G" _
& vbCr & _
" Test.txt will find only the files named TEST.TXT" _
& vbCr, _
"Enter file name to match:", Default:=strDefaultMatch)
If Len(strFileNameFilter) = 0 Then
varAnswer = _
MsgBox("Continue Search?", vbExclamation + vbYesNo, _
"Cancel or Continue...")
If varAnswer = vbNo Then
GoTo Exit_ListFiles
End If
End If
If Len(strFileNameFilter) = 0 Then
strFileBoxDesc = "*.*"
strFileNameFilter = "*.*"
Else
strFileBoxDesc = strFileNameFilter
End If
Msg = "Select location of files to be " & _
"listed or press Cancel."
'Allow user to select folder(s)
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = Left(ActiveWorkbook.FullName, _
Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.name))
.Title = Msg
.Show
strDirectory = .SelectedItems(1)
End With
If strDirectory = "" Then
Exit Sub
End If
If Right(strDirectory, 1) <> Application.PathSeparator Then
strDirectory = strDirectory & Application.PathSeparator
End If
varSubFolders = _
MsgBox("Search Sub-Folders of " & strDirectory & " ?", _
vbInformation + vbYesNoCancel, "Search Sub-Folders?")
If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Sub
'check for an active workbook
' if no workbooks open, create one
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If
'save name of current worksheet
strWorksheetName = ActiveSheet.name
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
Exit For
End If
Next
'Add new worksheet where results will be located
Worksheets.Add.Move after:=Worksheets(ActiveSheet.name)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Hyperlink"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Path"
ActiveWorkbook.ActiveSheet.Range("C1").value = "FileName"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Extension"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Size"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Last Modified"
ActiveWorkbook.ActiveSheet.Range("G1").value = "Last Accessed"
ActiveWorkbook.ActiveSheet.Range("H1").value = "Created"
ActiveWorkbook.ActiveSheet.Range("I1").value = "Attribute"
ActiveWorkbook.ActiveSheet.Range("J1").value = "Type"
Range("A1:E1").Font.Bold = True
R = R + 1
'get 1st filename
strName = Dir(strDirectory & strFileNameFilter)
On Error Resume Next
Application.StatusBar = strMessage_Wait1
'put filenames and file info into array
Do While strName <> vbNullString
k = k + 1
strArr(k, 1) = strDirectory & strName
strArr(k, 2) = FileLen(strDirectory & strName)
strArr(k, 3) = FileDateTime(strDirectory & "\" & strName)
strName = Dir()
Loop
'create late-binding file objects
Set fso = CreateObject("Scripting.FileSystemObject")
'get subfolder filenames if subfolder option selected
If blnSubFolders Then
Call recurseSubFolders(fso.GetFolder(strDirectory), _
strArr(), k, strFileNameFilter)
End If
'put file info on worksheet
If k > 0 Then
For i = 1 To k
strFileName = ""
strPath = ""
For y = Len(strArr(i, 1)) To 1 Step -1
If Mid(strArr(i, 1), y, 1) = _
Application.PathSeparator Then
Exit For
End If
strFileName = _
Mid(strArr(i, 1), y, 1) & strFileName
Next y
strPath = _
Left(strArr(i, 1), _
Len(strArr(i, 1)) - Len(strFileName))
strExtension = ""
For y = Len(strFileName) To 1 Step -1
If Mid(strFileName, y, 1) = "." Then
If Len(strFileName) - y <> 0 Then
strExtension = Right(strFileName, _
Len(strFileName) - y + 1)
strFileName = Left(strFileName, y - 1)
Exit For
End If
End If
Next y
Cells(R, 1) = strArr(i, 1)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(R, 1), _
Address:=strArr(i, 1)
Cells(R, 2) = strPath
Cells(R, 3) = strFileName
Cells(R, 4) = strExtension
Cells(R, 5) = FileLen(strArr(i, 1))
Cells(R, 6) = fso.GetFile(strArr(i, 1)).DateLastModified
Cells(R, 7) = fso.GetFile(strArr(i, 1)).DateLastAccessed
Cells(R, 8) = fso.GetFile(strArr(i, 1)).DateCreated
Cells(R, 9) = GetFileAttributeName(GetAttr(strArr(i, 1)))
Cells(R, 10) = fso.GetFile(strArr(i, 1)).Type
R = R + 1
Next i
End If
'formatting
Application.StatusBar = strMessage_Wait2
ActiveWindow.Zoom = 75
Columns("E:E").Select
With Selection
.NumberFormat = _
"_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
End With
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Columns("A:J").EntireColumn.AutoFit
Columns("A:A").Select
If Selection.ColumnWidth > 12 Then
Selection.ColumnWidth = 12
End If
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = 65000
ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
If Len(strFileNameFilter) = 0 Then
strFileNameFilter = "*.*"
End If
If blnSubFolders Then
strDirectory = "(including Subfolders) - " & strDirectory
End If
Application.ActiveCell.Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & _
" files(s) found for Criteria: " & _
strDirectory & strFileNameFilter & Chr(34)
Selection.Font.Bold = True
Range("B3").Select
Selection.Sort Key1:=Range("B3"), _
Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
Range("A3").Select
Application.Dialogs(xlDialogWorkbookName).Show
Exit_ListFiles:
Application.StatusBar = False
Exit Sub
Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles
End Sub
'/===========================================/
' Sub Purpose: recursive for filesearch 2007
'/===========================================/
'
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long, _
ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
On Error GoTo err_Sub
For Each SubFolder In Folder.SubFolders
'get 1st filename in subfolder
strName = Dir(SubFolder.Path & "\" & searchTerm)
'put filenames and file info in subfolders into array
Do While strName <> vbNullString
i = i + 1
strArr(i, 1) = SubFolder.Path & "\" & strName
strArr(i, 2) = FileLen(SubFolder.Path & "\" & strName)
strArr(i, 3) = FileDateTime(SubFolder.Path & "\" & strName)
strName = Dir()
Loop
Call recurseSubFolders(SubFolder, strArr(), i, searchTerm)
Next
exit_Sub:
On Error Resume Next
Exit Sub
err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: recurseSubFolders - Module: " & _
"Mod_Testing - " & Now()
GoTo exit_Sub
End Sub
'/===========================================/
' Function Purpose: returns file attribute description
'/===========================================/
'
Private Function GetFileAttributeName(fileAttribute As Long) As String
On Error GoTo err_Function
Select Case fileAttribute
Case 0 'vbNormal
GetFileAttributeName = "Normal"
Case 1 'vbReadOnly
GetFileAttributeName = "Read-Only"
Case 2 'vbHidden
GetFileAttributeName = "Hidden"
Case 4 'vbSystem
GetFileAttributeName = "System"
Case 8 'vbVolume
GetFileAttributeName = "Volume"
Case 16 'vbDirectory
GetFileAttributeName = "Directory"
Case 32 'vbNormal
GetFileAttributeName = "Normal"
Case 33 'vbReadOnly
GetFileAttributeName = "Read-Only"
Case 34 'vbHidden
GetFileAttributeName = "Hidden"
Case Else
GetFileAttributeName = "Unknown"
End Select
exit_Function:
On Error Resume Next
Exit Function
err_Function:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Function: GetFileAttributeName - " & Now()
GoTo exit_Function
End Function
'/===========================================/
