From a Deja Troll
' CreateXLAllFolderList
' Version 1.0 Stuart W Moore 23rd July 2002
'Adapted from Script in g:\vb5\scripting
'Needs Reference to Microsoft Scripting Runtime c:\winnt\system32\scrrun.dll
' *** ************************************** OR c:\windows\system\scrrun.dll
'This script will prompt for a folder path and create an Excel worksheet
'containing the file details. This version will look at the top level
'folder and all subfolders.
Dim fso As FileSystemObject, objXL As Application
Dim Message_Txt As String, Title_Txt As String
Dim filename As String, folderspec As String
Dim result As Boolean
Dim irow As Long, l As Integer
Dim ff As Files
Sub AllFilesList()
Call Welcome
folderspec = InputBox("Enter a pathname to return a list of files: ", _
Title_Txt)
If IsEmpty(folderspec) Then
Exit Sub
End If
Set fso = New FileSystemObject
If Not fso.FolderExists(folderspec) Then
MsgBox "No such Folder as '" & folderspec & "'!", vbOKOnly + vbExclamation, Title_Txt
Exit Sub
End If
Set objXL = Application
objXL.Workbooks.Add
objXL.Visible = True
objXL.DisplayAlerts = False
Do Until ActiveWorkbook.Sheets.Count = 1
ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count).Delete
Loop
objXL.DisplayAlerts = True
objXL.Cells(2, 1).Value = "Parent Folder"
objXL.Cells(2, 2).Value = "Filename"
objXL.Cells(2, 3).Value = "Size, KB"
objXL.Cells(2, 4).Value = "Type"
objXL.Cells(2, 5).Value = "Created"
objXL.Cells(2, 6).Value = "Last Accessed"
objXL.Cells(2, 7).Value = "Last Modified"
objXL.Rows(2).Select
objXL.Selection.Font.Bold = True
objXL.Range("A:B").ColumnWidth = 30
objXL.Range("C:C").ColumnWidth = 10
objXL.Range("D:D").ColumnWidth = 30
objXL.Range("E:G").ColumnWidth = 15
objXL.Columns(2).Select
objXL.Selection.NumberFormat = "@"
objXL.Columns(3).Select
objXL.Selection.Cells.NumberFormat = "0.0"
objXL.Range("A1").Select
objXL.StatusBar = "Working, please wait...."
irow = 2
If Right(folderspec, 1) = "\" Then
l = Len(folderspec) + 1
Else
l = Len(folderspec) + 2
End If
result = CreateXLFolderList(folderspec)
'Now sort out the Worksheet
objXL.Cells.Select
objXL.Selection.Columns.AutoFit
objXL.Selection.AutoFilter
objXL.Cells(1, 1).Select
objXL.Cells(1, 1).Value = "List of all " & (irow - 2) & " files in " & folderspec & " at " & Time & " on " & Date
objXL.Rows(1).Select
objXL.Selection.Font.Bold = True
objXL.Selection.Font.Size = 14
objXL.Cells(3, 1).Select
objXL.ActiveWindow.FreezePanes = True
objXL.StatusBar = False
'Tidy up
Set objXL = Nothing
Set ff = Nothing
Set fso = Nothing
End Sub
Sub Welcome()
Message_Txt = "This script will create an Excel worksheet" & vbCrLf & _
"containing details of all the files in the " & vbCrLf & _
"specified folder and its subfolders (if any)"
Title_Txt = "CreateXLAllFolderList V1.0 SWM 23/07/2002"
Dim intDoIt
intDoIt = MsgBox(Message_Txt, vbOKCancel + vbInformation, Title_Txt)
If intDoIt = vbCancel Then
End
End If
End Sub
Private Function CreateXLFolderList(fspec)
Dim f As Folder, f1 As File, fc As Files, s As Folder, sPart As String
Set f = fso.getfolder(fspec)
On Error Resume Next
If f.Files.Count <> 0 Then
Set fc = f.Files
For Each f1 In fc
irow = irow + 1
objXL.StatusBar = "Working....." & irow - 2 & " files found"
'Exclude from the listed pathname the spec originally entered
sPart = Mid(f1.Path, l)
'Knock off the filename part
sPart = Left(sPart, Len(sPart) - Len(f1.Name))
objXL.Cells(irow, 1).Value = sPart
objXL.Cells(irow, 2).Value = f1.Name
objXL.Cells(irow, 3).Value = f1.Size / 1024
objXL.Cells(irow, 4).Value = f1.Type
objXL.Cells(irow, 5).Value = f1.DateCreated
objXL.Cells(irow, 6).Value = f1.DateLastAccessed
objXL.Cells(irow, 7).Value = f1.DateLastModified
Next
End If
'This is the recursive bit
If f.subfolders.Count > 0 Then
For Each s In f.subfolders
CreateXLFolderList (s)
Next
End If
CreateXLFolderList = True
End Function
Previous Topic
Index