Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to list files
Hi. Can someone put me to a macro that will list the
files in a given directory? I know I have seen this post before, but I cannot find it. Thanks, Mike. |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 '================================================= ===== |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to list files
Hi Mike
Try this for the folder C:\Data Run it with a empty sheet active Sub test2() Dim i As Long With Application.FileSearch .NewSearch .LookIn = "C:\Data" .SearchSubFolders = False .MatchTextExactly = False .FileType = msoFileTypeAllFiles 'If .Execute(msoSortByFileName) 0 Then If .Execute(msoSortOrderDescending) 0 Then MsgBox "There were " & .FoundFiles.Count & " file(s) found." For i = 1 To .FoundFiles.Count Cells(i, 1).Value = .FoundFiles(i) Cells(i, 2).Value = FileDateTime(.FoundFiles(i)) Cells(i, 3).Value = FileLen(.FoundFiles(i)) Next i Else MsgBox "There were no files found." End If End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl "Mike D." wrote in message ... Hi. Can someone put me to a macro that will list the files in a given directory? I know I have seen this post before, but I cannot find it. Thanks, Mike. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
macro to list folders only, not files | Excel Worksheet Functions | |||
macro to print files from a list of links | Excel Discussion (Misc queries) | |||
list box- list all files ina directory | Excel Programming | |||
adding Tiff files to the list of image files | Excel Programming | |||
Import multiple files macro can't find files | Excel Programming |