ExcelBanter - Macro to list files

'created using John Walkenbach's "Microsoft Excel 2000
Power
' Programming with VBA" example as a basic starting point
'================================================= =====
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

'================================================= =====
'Public Type BROWSEINFO
Private 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
'================================================= =====

Public Sub ListFilesToWorksheet()
On Error Resume Next
'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
Dim aryHiddensheets()
Dim blnSubFolders As Boolean
Dim dblLastRow As Long
Dim i As Integer, r As Integer, x As Integer
Dim y As Integer, iWorksheets As Integer
Dim Msg As String, Directory As String, strPath As
String
Dim strResultsTableName As String, strFileName 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

'/==========Variables=============
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..."
'/==========Variables=============

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 = "All MSOffice files"
Else
strFileBoxDesc = strFileNameFilter
End If

Msg = "Look for: " & strFileBoxDesc & vbCrLf & _
" - Select location of files to be listed or press
Cancel."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) < "\" Then Directory =
Directory & "\"

varSubFolders = _
MsgBox("Search Sub-Folders of " & Directory
& " ?", _
vbInformation + vbYesNoCancel, "Search Sub-
Folders?")

If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Sub

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'redim array
ReDim aryHiddensheets(1 To iWorksheets)

'put hidden sheets in an array, then unhide the sheets
For x = 1 To iWorksheets
If Worksheets(x).Visible = False Then
aryHiddensheets(x) = Worksheets(x).Name
Worksheets(x).Visible = True
End If
Next

'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
warning messages off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn
warning messages on
Exit For
End If
Next

'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)

'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
= "Date/Time"
Range("A1:E1").Font.Bold = True

r = r + 1

On Error Resume Next
Application.StatusBar = strMessage_Wait1
With Application.FileSearch
.NewSearch
.LookIn = Directory
If strFileNameFilter = "*.*" Then _
.FileType = msoFileTypeAllFiles
If Len(strFileNameFilter) = 0 Then _
.FileType = msoFileTypeOfficeFiles
'.FileName = "*.*"
.FileName = strFileNameFilter
'.SearchSubFolders = False
.SearchSubFolders = blnSubFolders
.Execute
For i = 1 To .FoundFiles.Count
strFileName = ""
strPath = ""
For y = Len(.FoundFiles(i)) To 1 Step -1
If Mid(.FoundFiles(i), y, 1) = "\" Then
Exit For
End If
strFileName = Mid(.FoundFiles(i), y, 1) &
strFileName
Next y
strPath = Left(.FoundFiles(i), Len(.FoundFiles
(i)) - _
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)
strFileName = Left(strFileName, y -
1)
Exit For
End If
End If
Next y
Cells(r, 1) = .FoundFiles(i)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r,
1), _
Address:=.FoundFiles(i)
Cells(r, 2) = strPath
Cells(r, 3) = strFileName
Cells(r, 4) = strExtension
Cells(r, 5) = FileLen(.FoundFiles(i))
Cells(r, 6) = FileDateTime(.FoundFiles(i))
r = r + 1
Next i
End With

'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:F").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 = ActiveSheet.Cells.SpecialCells
(xlLastCell).Row
dblLastRow = dblLastRow + 1

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
If Len(strFileNameFilter) = 0 Then
strFileNameFilter = "All MSOffice products"
End If
If blnSubFolders Then
Directory = "(including Subfolders) - " & Directory
End If

Application.ActiveCell.Formula = "=COUNTA(A3:A" & _
dblLastRow & ") & " & Chr(34) & _
" files(s) found for Criteria: " & _
Directory & 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

're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next

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

'================================================= =====
Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, 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
End If

' 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
'================================================= =====