Hi All.
I have this wonderful code that did amazing things in XL2003 and earlier Win OS.
It doesn't work in XL 2013 on Win7/8.
Can someone assist with modifying code?
Thanks
I think this code was modified by David Kaufman.
I have this wonderful code that did amazing things in XL2003 and earlier Win OS.
It doesn't work in XL 2013 on Win7/8.
Can someone assist with modifying code?
Thanks
I think this code was modified by David Kaufman.
Code:
Option Explicit
'created using John Walkenbach's "Microsoft Excel 2000 Power
' Programming with VBA" example as a basic starting point
'====================================
'32-bit API declarations
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Declare PtrSafe 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
'=====================================
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 Double
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
'/==========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
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
'.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
'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
Exit_ListFiles:
Application.StatusBar = False
Exit Sub
Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles
End Sub
'=======================================
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
