Class Module Alternative
Application.FileSearch - Class
Dim pLookIn As String
Dim pSearchSubFolders As Boolean
Dim pFileName As String
Public FoundFiles As New Collection
Public Property Get LookIn() As String
LookIn = pLookIn
End Property
Public Property Let LookIn(value As String)
pLookIn = value
End Property
Public Property Get SearchSubFolders() As Boolean
LookIn = pSearchSubFolders
End Property
Public Property Let SearchSubFolders(value As Boolean)
pSearchSubFolders = value
End Property
Public Property Get fileName() As String
fileName = pFileName
End Property
Public Property Let fileName(value As String)
pFileName = value
End Property
Public Function Execute() As Long
Dim ex As Long
Dim sLookIn As String
Dim sDirName As String
Dim sSubDir As String
Dim sFileName As String
Dim ff As FilesFound
Set ff = New FilesFound
sLookIn = LookIn
sDirName = Dir(sLookIn, vbDirectory)
sFileName = Dir(sLookIn & "\", vbNormal)
Do Until Len(sFileName) = 0
If sFileName Like fileName Then
ff.AddFile sLookIn, sFileName
FoundFiles.Add (ff.FoundFileFullName)
End If
sFileName = Dir
Loop
If SearchSubFolders Then
Do Until Len(sDirName) = 0
If GetAttr(sLookIn & sDirName) = vbDirectory Then
sSubDir = sDirName
Do Until Len(sFileName) = 0
If GetAttr(sDirName) = vbNormal Then
sFileName = sDirName
ff.AddFile sDirName, sFileName
FoundFiles.Add (ff)
End If
Loop
End If
sDirName = Dir
Loop
End If
Execute = FoundFiles.Count
End Function
The second I named FilesFound and the code is as follows:
Public FoundFileFullName As String
Public Function AddFile(path As String, fileName As String)
FoundFileFullName = path & "\" & fileName
End Function
To use it in your code just create the two class modules and then use it as such:
Dim sFile as String
Dim fs As New FileSearh
With fs
.LookIn = sPath
.SearchSubFolders = True
.fileName = "*"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
sFile = .FoundFiles(i)
' your code here
Next
End If
End With
Example 2
Sub FileSearchByHavrda_Example_of_procedure_calling()
Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection ' create a collection of filenames
' Filling a collection of filenames (search Excel files including subdirectories)
Call FileSearchByHavrda(ListOfFilenamesWithParh, "C:\Temp", "*.xls", True)
' Print list to immediate debug window and as a message window
For Each FileNameWithPath In ListOfFilenamesWithParh ' cycle for list(collection) processing
Debug.Print FileNameWithPath & Chr(13)
MsgBox FileNameWithPath & Chr(13)
Next FileNameWithPath
' Print to immediate debug window and message if no file was found
If ListOfFilenamesWithParh.Count = 0 Then
Debug.Print "No file was found !"
MsgBox "No file was found !"
End If
End Sub
//------------------------------------------------------------------------------------------------
Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic
'
Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection
' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"
' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile 'add file name to list(collection)
DirFile = Dir ' next file
Loop
' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub
' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
' Add subdirectory to local list(collection) of subdirectories in path
If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
DirFile = Dir 'next file
Loop
' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
Next
End Sub
Application.FileSearch - Replacement
Set objCollection = Folder_GetFilesDirToCollection("C:\Temp\", "FileName_With_Wildcards*.csv")
Public Function Folder_GetFilesDirToCollection(ByVal sFolderPath As String, _
ByVal sPattern As String) As Collection
Dim objCollection As Collection
Dim sFileName As String
On Error GoTo AnError
sFileName = Dir(sFolderPath & sPattern)
Set objCollection = New Collection
Do While Len(sFileName) > 0
objCollection.Add (sFileName)
sFileName = Dir()
Loop
Set Folder_GetFilesDirToCollection = objCollection
Exit Function
AnError:
Call MsgBox(Err.Number & " - " & Err.Description)
End Function
Need code to get the last modified file
Public Function Folder_GetFileLastModified(ByVal sFolderPath As String, _
ByVal sPattern As String) As String
Dim objCollection As Collection
Dim sFileName As String
Dim dtLastModified As Date
Dim sLastModified As String
On Error GoTo AnError
sFileName = Dir(sFolderPath & sPattern)
Set objCollection = New Collection
sLastModified = sFileName
dtLastModified = DateSerial(2010, 1, 1)
Do While Len(sFileName) > 0
If (FileDateTime(sFolderPath & sFileName) > dtLastModified) Then
sLastModified = sFileName
End If
objCollection.Add (sFileName & "-" & FileDateTime(sFolderPath & sFileName))
sFileName = Dir()
Loop
Folder_GetFileLastModified = sLastModified
Exit Function
AnError:
Call MsgBox(Err.Number & " - " & Err.Description)
End Function
Public Sub Test_sPopulateHistory()
Dim vaFiles As Variant
vaFiles = Folder_GetFilesLastModifiedToArray("C:\Temp\", "FileName_With_Wildcards*.csv")
Stop
End Sub
Public Function Folder_GetFilesLastModifiedToArray(ByVal sFolderPath As String, _
ByVal sPattern As String) As Variant
Dim vaFiles() As Variant
Dim vaFilesCopy() As Variant
Dim sFileName As String
Dim iarraycount As Integer
On Error GoTo AnError
sFileName = Dir(sFolderPath & sPattern)
ReDim Preserve vaFiles(1, 2000)
Do While Len(sFileName) > 0
vaFiles(0, iarraycount) = sFileName
vaFiles(1, iarraycount) = FileDateTime(sFolderPath & sFileName)
sFileName = Dir()
iarraycount = iarraycount + 1
Loop
If iarraycount > 0 Then
ReDim Preserve vaFiles(1, iarraycount - 1)
ReDim Preserve vaFilesCopy(1, iarraycount - 1)
For iarraycount = 0 To UBound(vaFiles, 2)
vaFilesCopy(0, iarraycount) = vaFiles(0, UBound(vaFiles, 2) - iarraycount)
vaFilesCopy(1, iarraycount) = vaFiles(1, UBound(vaFiles, 2) - iarraycount)
Next iarraycount
End if
Folder_GetFilesLastModifiedToArray = vaFilesCopy
Exit Function
AnError:
Call MsgBox(Err.Number & " - " & Err.Description)
End Function
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext