Here is a macro I have used for several years that will list all the files
in one folder:
Sub FolderListDocuments()
On Error GoTo OOPS
Dim x, fs
Dim i As Integer
Dim y As Integer
Dim Folder, MyName, TotalFiles, Response, PrintResponse, AgainResponse
On Error Resume Next
Folder:
' Prompt the user for the folder to list.
x = InputBox("What folder do you want to list?" & Chr$(13) & Chr$(13) _
& "For example: C:\My Documents")
If x = "" Or x = " " Then
Response = MsgBox("Either you did not type a folder name correctly" _
& Chr$(13) & "or you clicked Cancel. Do you want to quit?" _
& Chr$(13) & Chr$(13) & _
"If you want to type a folder name, click No." & Chr$(13) & _
"If you want to quit, click Yes.", vbYesNo)
If Response = "6" Then
End
Else
GoTo Folder
End If
Else
' Test if folder exists.
Set Folder = CreateObject("Scripting.filesystemobject")
If Folder.folderexists(x) = "True" Then
' Search the specified folder for files and type the listing in the '
document.
With Application.FileSearch
Set fs = Application.FileSearch
fs.NewSearch
With fs.PropertyTests
.Add Name:="Files of Type", _
Condition:=msoConditionFileTypeDocuments, _
Connector:=msoConnectorOr
End With
.LookIn = x
.Execute
TotalFiles = .FoundFiles.Count
If TotalFiles <> 0 Then
' Create a new document for the file listing.
Application.Documents.Add
ActiveDocument.ActiveWindow.View = wdPrintView
' Set tabs.
Selection.WholeStory
Selection.ParagraphFormat.TabStops.ClearAll
ActiveDocument.DefaultTabStop = InchesToPoints(0.5)
Selection.ParagraphFormat.TabStops.Add _
Position:=InchesToPoints(3), _
Alignment:=wdAlignTabLeft, _
Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops.Add _
Position:=InchesToPoints(4), _
Alignment:=wdAlignTabLeft, _
Leader:=wdTabLeaderSpaces
' Type the file list headings.
Selection.TypeText "File Listing of the "
With Selection.Font
.AllCaps = True
.Bold = True
End With
Selection.TypeText x
With Selection.Font
.AllCaps = False
.Bold = False
End With
Selection.TypeText " folder!" & Chr$(13)
With Selection.Font
.Underline = wdUnderlineSingle
End With
With Selection
.TypeText Chr$(13)
.TypeText "File Name" & vbTab & "File Size" _
& vbTab & "File Date/Time" & Chr$(13)
.TypeText Chr$(13)
End With
With Selection.Font
.Underline = wdUnderlineNone
End With
Else
MsgBox ("There are no files in the folder!" & _
"Please type another folder to list.")
GoTo Folder
End If
For i = 1 To TotalFiles
MyName = .FoundFiles.Item(i)
.FileName = MyName
Selection.TypeText .FileName & vbTab & FileLen(MyName) _
& vbTab & FileDateTime(MyName) & Chr$(13)
Next i
' Type the total number of files found.
Selection.TypeText Chr$(13)
Selection.TypeText "Total files in folder = " & TotalFiles & _
" files."
End With
Else
MsgBox "The folder does not exist. Please try again."
GoTo Folder
End If
End If
PrintResponse = MsgBox("Do you want to print this folder list?", vbYesNo)
If PrintResponse = "6" Then
Application.ActiveDocument.PrintOut
End If
AgainResponse = MsgBox("Do you want to list another folder?", vbYesNo)
If AgainResponse = "6" Then
GoTo Folder
Else
End
End If
OOPS:
If Err.Number <> 0 Then MsgBox Err.Description
End:
End Sub
