Return File info from a directory
Posted by Steve Lisa on July 10, 2001 12:58 PM
Do you have any suggestions on the best way to add to
this code? I'd like to display the FileSize in range B:B
and the FileDate in range C:C
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Sub test()
Dim p As String, x As Variant
p = "C:\TEMP\*.xls"
x = GetFileList(p)
Select Case IsArray(x)
Case True 'files found
'MsgBox UBound(x)
Sheets("Sheet1").Range("A:A").Clear
For i = LBound(x) To UBound(x)
Sheets("Sheet1").Cells(i, 1).Value = x(i)
Next i
Case False 'no files found
MsgBox "No matching files"
End Select
End Sub
Thanks in advance . . . .
.
Posted by Ivan F Moala on July 10, 2001 2:38 PM
Steve.....this is how i would do it...noted the
use of array variants = fast way to access data
for writting back....hence the change in some of
the code.....which works pretty fast..rather then
looping through.
Option Explicit
Option Base 1
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileSearch
Dim FileArray() As Variant
Dim i As Double
On Error GoTo ErrSearch
Set FileSearch = Application.FileSearch
With FileSearch
.LookIn = FileSpec
.FileName = "*.xls"
If .Execute > 0 Then
ReDim FileArray(.FoundFiles.Count, 3)
For i = 1 To .FoundFiles.Count
FileArray(i, 1) = .FoundFiles(i)
FileArray(i, 2) = FileLen(.FoundFiles(i)) \ 1024 & " Kb"
FileArray(i, 3) = Format(FileDateTime(.FoundFiles(i)), "dd/mm/yy hh:mm:ss")
Next
Else
GetFileList = False
Exit Function
End If
End With
GetFileList = FileArray
Exit Function
' Error handler
ErrSearch:
MsgBox Err.Number & " : " & Err.Description, vbMsgBoxHelpButton, _
"Error Search", Err.HelpFile, Err.HelpContext
End
End Function
Sub test()
Dim p As String, x As Variant, i As Double
p = "C:\Temp"
x = GetFileList(p)
Select Case IsArray(x)
Case True 'files found
Sheets("Sheet1").Range("A:C").Clear
Sheets("Sheet1").Range("A1").Resize(UBound(x), 3) = x
Sheets("Sheet1").Range("A:C").Columns.AutoFit
MsgBox "Done!...." & UBound(x) & " files found"
Case False 'no files found
MsgBox "No matching files"
End Select
End Sub
HTH
Ivan
Posted by Ivan F Moala on July 10, 2001 3:01 PM
Slight adj - for error if Dir non existant
Option Explicit
Option Base 1
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileSearch
Dim FileArray() As Variant
Dim i As Double
Dim Exists
On Error GoTo ErrSearch
Set FileSearch = Application.FileSearch
Exists = Dir(FileSpec)
If Exists = "" Then GoTo ErrSearch
With FileSearch
.NewSearch
.LookIn = FileSpec
.FileName = "*.xls"
If .Execute > 0 Then
ReDim FileArray(.FoundFiles.Count, 3)
For i = 1 To .FoundFiles.Count
FileArray(i, 1) = .FoundFiles(i)
FileArray(i, 2) = FileLen(.FoundFiles(i)) \ 1024 & " Kb"
FileArray(i, 3) = Format(FileDateTime(.FoundFiles(i)), "dd/mm/yy hh:mm:ss")
Next
Else
GetFileList = False
Exit Function
End If
End With
GetFileList = FileArray
Set FileSearch = Nothing
Exit Function
' Error handler
ErrSearch:
If Exists = "" Then On Error Resume Next: Err.Raise 76
MsgBox Err.Number & " : " & Err.Description, vbMsgBoxHelpButton, _
"Error Search", Err.HelpFile, Err.HelpContext
End
End Function
Sub test()
Dim p As String, x As Variant, i As Double
p = "C:\a" ' "C:\ExcelFiles\Useful\"
x = GetFileList(p)
Select Case IsArray(x)
Case True 'files found
Sheets("Sheet1").Range("A:C").Clear
Sheets("Sheet1").Range("A1").Resize(UBound(x), 3) = x
Sheets("Sheet1").Range("A:C").Columns.AutoFit
MsgBox "Done!...." & UBound(x) & " files found"
Case False 'no files found
MsgBox "No matching files"
End Select
x = ""
End Sub
