This will get you the creation date OR the last modified date, whichever is
later.
The main macro is called 'ListFilesToWorksheet'.
Some of the variables aren't applicable because I grabbed this from Excel
and changed it over to Access for you but didn't go back and try to remember
which variables are no longer needed. Works fine anyway.
'/== M A C R O == S T A R T S == H E R E ==/
' Sub Purpose:
' - Get file path, name, extension, length and created or
' last modified data
' - Creates a CSV file (see strResultsFileName variable below)
' - 08/26/2009 Change from MS Excel to MS Access and
' writing data to file
'/================================/
'
Public Sub ListFilesToWorksheet()
Dim blnSubFolders As Boolean
Dim R As Integer, x As Integer
Dim y As Integer, iFileNum As Integer
Dim i As Long, j As Long, k As Long
Dim fso As Object
Dim Msg As String, strDirectory As String, strPath As String
Dim strResultsFileName As String, strFileName As String
Dim strWorksheetName As String
Dim strArr() As String
Dim strName 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
On Error Resume Next
'- - - - V A R I A B L E S - - - - - - - - -
strResultsFileName = "C:\Temp\File_Listing.csv"
strDefaultMatch = "*.*"
R = 1
i = 1
blnSubFolders = False
ReDim strArr(1 To 65536, 1 To 3)
'- - - - - - - - - - - - - - - - - - - - - -
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_Sub
End If
End If
If Len(strFileNameFilter) = 0 Then
strFileBoxDesc = "*.*"
strFileNameFilter = "*.*"
Else
strFileBoxDesc = strFileNameFilter
End If
Msg = "Select location of files to be " & _
"listed or press Cancel."
'Allow user to select folder(s)
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = ""
.Title = Msg
.Show
strDirectory = .SelectedItems(1)
End With
If strDirectory = "" Then
Exit Sub
End If
If Right(strDirectory, 1) <> "\" Then
strDirectory = strDirectory & "\"
End If
varSubFolders = _
MsgBox("Search Sub-Folders of " & strDirectory & " ?", _
vbInformation + vbYesNoCancel, "Search Sub-Folders?")
If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Sub
'if file already exists, delete it
Kill strResultsFileName
'get 1st filename
strName = Dir(strDirectory & strFileNameFilter)
On Error Resume Next
'put filenames and file info into array
Do While strName <> vbNullString
k = k + 1
strArr(k, 1) = strDirectory & strName
strArr(k, 2) = FileLen(strDirectory & strName)
strArr(k, 3) = FileDateTime(strDirectory & "\" & strName)
strName = Dir()
Loop
'get subfolder filenames if subfolder option selected
If blnSubFolders Then
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDirectory), _
strArr(), k, strFileNameFilter)
End If
'put file info into file strResultsFileName
If k > 0 Then
'open file
iFileNum = FreeFile()
Open strResultsFileName For Output As #iFileNum
'process each file name
For i = 1 To k
strFileName = ""
strPath = ""
For y = Len(strArr(i, 1)) To 1 Step -1
If Mid(strArr(i, 1), y, 1) = "\" Then
Exit For
End If
strFileName = _
Mid(strArr(i, 1), y, 1) & strFileName
Next y
strPath = _
Left(strArr(i, 1), _
Len(strArr(i, 1)) - 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 + 1)
strFileName = Left(strFileName, y - 1)
Exit For
End If
End If
Next y
'actually put the data in the file
Write #iFileNum, _
strPath, _
strFileName, _
strExtension, _
FileLen(strArr(i, 1)), _
FileDateTime(strArr(i, 1))
Next i
End If
'close the file
Close #iFileNum
exit_Sub:
On Error Resume Next
Exit Sub
err_Sub:
MsgBox "Error: " & Err & " - " & Err.Description
Resume exit_Sub
End Sub
'/================================/
' Sub Purpose: recursive for filesearch 2007
' compatability with Office 2007
'/================================/
'
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long, _
ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
On Error GoTo err_Sub
For Each SubFolder In Folder.SubFolders
'get 1st filename in subfolder
strName = Dir(SubFolder.Path & "\" & searchTerm)
'put filenames and file info in subfolders into array
Do While strName <> vbNullString
i = i + 1
strArr(i, 1) = SubFolder.Path & "\" & strName
strArr(i, 2) = FileLen(SubFolder.Path & "\" & strName)
strArr(i, 3) = FileDateTime(SubFolder.Path & "\" & strName)
strName = Dir()
Loop
Call recurseSubFolders(SubFolder, strArr(), i, searchTerm)
Next
exit_Sub:
On Error Resume Next
Exit Sub
err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: recurseSubFolders - " & Now()
GoTo exit_Sub
End Sub
'/== M A C R O == E N D S == H E R E ==/
--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown
