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