We help IT Professionals succeed at work.

Alternative for Application.Filesearch in Office 2010 - VBA

VBAlearner2010
VBAlearner2010 asked
on
I am pasting a code block below.. Which uses some iteration withing Application.Filesearch. Could anyone edit the code for me to make it work in 2010. I hope Application.Filesearch does not work in office 2010. It would be helpful to know some comments on the code.
Private Sub FichImporte_GotFocus()
Dim CSql As String
Dim rst As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim intLenRep As Integer
Dim intLen As Integer

Set cnn = CurrentProject.Connection

intLenRep = Len(stRepCh)

    cnn.Execute "DELETE FROM FICHIERS_TROUVES"

    Set rst = New ADODB.Recordset
    Set rs1 = New ADODB.Recordset

    'Active la connection de la base Access
    Set rst.ActiveConnection = cnn
    CSql = "FICHIERS_TROUVES;"

    'Ouvre le recordset qui correspond à la table ci-dessous.
    rst.Open CSql, , adOpenKeyset, adLockOptimistic

    With Application.FileSearch
        'Débute une nouvelle recherche
        .NewSearch
        'Définit les critères de recherche
        .LookIn = stRepCh
        .FileName = "*.*"
        .SearchSubFolders = True
    End With


With Application.FileSearch
    'Exécute la recherche
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                'TextBox.Value = .FoundFiles(i)
                intLen = Len(.FoundFiles(i))
                stFichier = Right(.FoundFiles(i), intLen - intLenRep)
                'Call ShowFileInfo(.FoundFiles(i))
                With rst
                    If Right(stFichier, 11) <> "_traite.xls" Then
                        .AddNew
                            .Fields(1) = stFichier
                            '.Fields(2) = s
                        .Update
                    End If
                End With
                
                
            Next i
        End If
End With
        FichImporte.Requery

End Sub

Open in new window

Comment
Watch Question

View Solutions Only

MINDSUPERB

Commented:
See the link below:

http://vbadud.blogspot.com/2010/02/office-2010-applicationfilesearch-error.html

It has work around solutions on this issue.

Sincerely,
Ed
Rory Archibald
CERTIFIED EXPERT
Most Valuable Expert 2011
Top Expert 2011
Commented:
Something like this:
Private Sub FichImporte_GotFocus()
   Dim CSql              As String
   Dim rst               As New ADODB.Recordset
   Dim rs1               As New ADODB.Recordset
   Dim intLenRep         As Integer
   Dim intLen            As Integer
   Set cnn = CurrentProject.Connection

   intLenRep = Len(stRepCh)

   cnn.Execute "DELETE FROM FICHIERS_TROUVES"

   Set rst = New ADODB.Recordset
   Set rs1 = New ADODB.Recordset

   'Active la connection de la base Access
   Set rst.ActiveConnection = cnn
   CSql = "FICHIERS_TROUVES;"

   'Ouvre le recordset qui correspond à la table ci-dessous.
   rst.Open CSql, , adOpenKeyset, adLockOptimistic

   stFichier = Dir(stRepCh & "*.*")
   Do While stFichier <> ""
      With rst
         If Right(stFichier, 11) <> "_traite.xls" Then
            .AddNew
            .Fields(1) = stFichier
            '.Fields(2) = s
            .Update
         End If
      End With
      stFichier = Dir
   Loop
   FichImporte.Requery

End Sub

Open in new window

Top Expert 2011
Commented:
This is a more general solution to this issue I wrote a while ago, which is intended to replace most common uses of Filesearch.  It is a custom class that has most of the properties and methods of the FileSearch object, and should behave in the same ways.  It needs a few steps to get working:

Insert a new class module called clsFileSearch and paste in this code: 
Option Explicit

Private mstrLookIn As String
Private mblnSearchSubFolders As Boolean
Private mstrFileName As String
Private mblnMatchTextExactly As Boolean
Private meFileType As MsoFileType
Private mobjFSO As Scripting.FileSystemObject
Private mcolFoundFiles As Collection
Private mobjRE As VBScript_RegExp_55.RegExp
Private mobjSortBy As MsoSortBy
Private mobjSortOrder As msosortorder
Private mblnAlwaysAccurate As Boolean
Private aFiles() As Variant
Private mlngFilesIX As Long
Private mlngFilesToGet As Long
Private mstrFileTypePattern As String

Private Const clngArrayChunk As Long = 1000



Public Property Get FoundFiles() As Collection

    Set FoundFiles = mcolFoundFiles

End Property

Private Sub Class_Initialize()
    Set mcolFoundFiles = New Collection
    Set mobjFSO = New Scripting.FileSystemObject
End Sub

Private Sub Class_Terminate()

    Set mcolFoundFiles = Nothing
    Set mobjFSO = Nothing
    Set mobjRE = Nothing

End Sub


Public Sub NewSearch()
    mstrLookIn = vbNullString
    mblnSearchSubFolders = False
    mblnMatchTextExactly = False
    meFileType = MsoFileType.msoFileTypeAllFiles
    Set mcolFoundFiles = New Collection
End Sub

Public Function Execute(Optional ByVal SortBy As MsoSortBy = MsoSortBy.msoSortByFileName, _
                            Optional ByVal SortOrder As msosortorder = msosortorder.msoSortOrderAscending, _
                            Optional ByVal AlwaysAccurate As Boolean = True) As Long

    Set mcolFoundFiles = New Collection
    
    mobjSortBy = SortBy
    mobjSortOrder = SortOrder
    mblnAlwaysAccurate = AlwaysAccurate
    
    Set mobjRE = New VBScript_RegExp_55.RegExp
    mobjRE.Pattern = GetREPattern(mstrFileName)
    mobjRE.Global = False
    mobjRE.IgnoreCase = True
    
    mlngFilesToGet = VBA.VbFileAttribute.vbArchive + VBA.VbFileAttribute.vbReadOnly
    If GetHiddenFilesSetting() Then
        mlngFilesToGet = mlngFilesToGet + VBA.VbFileAttribute.vbHidden
    End If
    
    Erase aFiles
    ReDim aFiles(4, clngArrayChunk - 1)
    mlngFilesIX = 0
    
    Call FindFiles(mstrLookIn)
    
    Call BuildCollection
    
    Execute = mcolFoundFiles.Count

End Function

Public Property Get LookIn() As String

    LookIn = mstrLookIn

End Property

Public Property Let LookIn(ByVal strLookIn As String)

    mstrLookIn = strLookIn

End Property

Public Property Get SearchSubFolders() As Boolean

    SearchSubFolders = mblnSearchSubFolders

End Property

Public Property Let SearchSubFolders(ByVal blnSearchSubFolders As Boolean)

    mblnSearchSubFolders = blnSearchSubFolders

End Property

Public Property Get FileName() As String

    FileName = mstrFileName

End Property

Public Property Let FileName(ByVal strFileName As String)

    mstrFileName = strFileName

End Property

Public Property Get MatchTextExactly() As Boolean

    MatchTextExactly = mblnMatchTextExactly

End Property

Public Property Let MatchTextExactly(ByVal blnMatchTextExactly As Boolean)

    mblnMatchTextExactly = blnMatchTextExactly

End Property

Public Property Get FileType() As MsoFileType

    FileType = meFileType

End Property

Public Property Let FileType(ByVal eFileType As MsoFileType)

    meFileType = eFileType
    
    Select Case meFileType

        Case msoFileTypeAllFiles

        Case msoFileTypeOfficeFiles

        Case msoFileTypeWordDocuments

        Case msoFileTypeExcelWorkbooks

        Case msoFileTypePowerPointPresentations

        Case msoFileTypeDatabases
        
        Case Else
        'Case msoFileTypeTemplates, msoFileTypeBinders, msoFileTypeOutlookItems, msoFileTypeMailItem, _
            msoFileTypeCalendarItem, msoFileTypeContactItem, msoFileTypeNoteItem, msoFileTypeJournalItem, _
            msoFileTypeTaskItem, msoFileTypePhotoDrawFiles, msoFileTypeDataConnectionFiles, _
            msoFileTypePublisherFiles, msoFileTypeProjectFiles, msoFileTypeDocumentImagingFiles, _
            msoFileTypeVisioFiles, msoFileTypeDesignerFiles, msoFileTypeWebPages
            Err.Raise vbObjectError + 1000, "clsFileSearch", _
                "FileType not supported by this interim version of FileSearch - use one of the following:" & vbCrLf & vbTab & _
             "msoFileTypeAllFiles" & vbCrLf & vbTab & _
             "msoFileTypeOfficeFiles" & vbCrLf & vbTab & _
             "msoFileTypeWordDocuments" & vbCrLf & vbTab & _
             "msoFileTypeExcelWorkbooks" & vbCrLf & vbTab & _
             "msoFileTypePowerPointPresentations"

    End Select

End Property

Private Sub FindFiles(ByVal strPath As String)
    Dim strFound As String
    Dim strFullPath As String
    Dim fldThis As Scripting.Folder
    Dim filThis As Scripting.File
    Dim fldSub As Scripting.Folder
    'Debug.Print strPath
    If mobjFSO.FolderExists(strPath) Then
        
        Set fldThis = mobjFSO.GetFolder(strPath)
        strFound = Dir$(mobjFSO.BuildPath(strPath, mstrFileName), mlngFilesToGet)
        Do While Len(strFound) > 0
            If mobjRE.Test(strFound) Then
                If Right$(strPath, 1) = "\" Then strPath = Left$(strPath, Len(strPath) - 1)
                strFullPath = strPath & "\" & strFound
                
                aFiles(0, mlngFilesIX) = strPath
                aFiles(1, mlngFilesIX) = strFound
                aFiles(2, mlngFilesIX) = Right(strFound, 4)
                aFiles(3, mlngFilesIX) = FileDateTime(strFullPath)
                aFiles(4, mlngFilesIX) = FileLen(strFullPath)
                
                mlngFilesIX = mlngFilesIX + 1
                If mlngFilesIX > UBound(aFiles, 2) Then
                    ReDim Preserve aFiles(4, UBound(aFiles, 2) + clngArrayChunk)
                End If
            End If
            strFound = Dir$()
        
        Loop
        
        If mblnSearchSubFolders Then
            For Each fldSub In fldThis.SubFolders
                Call FindFiles(fldSub.Path)
            Next fldSub
        End If
        
    End If
    
End Sub

Private Function GetREPattern(ByVal strSrch As String) As String
    Dim strRslt As String
    strRslt = strSrch
    With mobjRE
        .Global = True
        .IgnoreCase = False
        
        .Pattern = "([()\[\]+^$.{}|\\])"
        strRslt = .Replace(strRslt, "\$1")
        
        .Pattern = "\?"
        strRslt = .Replace(strRslt, ".")
        
        .Pattern = "\*"
        strRslt = .Replace(strRslt, ".*")
        
    End With
    GetREPattern = "^" & strRslt & "$"
End Function

Private Function GetHiddenFilesSetting() As Boolean
    Dim sh As Object
    Dim vSetting As String
    Dim strKey As String
    
    Set sh = CreateObject("WScript.Shell")
    
    strKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden"
    vSetting = sh.RegRead(strKey)
    
    If vSetting = 1 Then
        GetHiddenFilesSetting = True
    Else
        GetHiddenFilesSetting = False
    End If
    
    Set sh = Nothing

End Function

Private Sub BuildCollection()
    
    Set mcolFoundFiles = New Collection
    Dim i As Long
    Dim lngFound As Long
    Dim strFoundItem As String
    Dim dtFoundItem As Date
    Dim lngFoundItem As Long

    If mlngFilesIX > 0 Then
        mlngFilesIX = mlngFilesIX - 1
        Select Case mobjSortBy
            Case MsoSortBy.msoSortByFileName, MsoSortBy.msoSortByFileType
                lngFound = 0
                Do While lngFound > -1
                    lngFound = -1
                    strFoundItem = ChrW(&HFFFF)
                    For i = 0 To mlngFilesIX
                        If Len(aFiles(1, i)) > 0 Then
                            If aFiles(1, i) < strFoundItem Then
                                strFoundItem = aFiles(1, i)
                                lngFound = i
                            End If
                        End If
                    Next i
                    If lngFound > -1 Then
                        If mobjSortOrder = msoSortOrderAscending Then
                            mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound)
                        Else
                            If mcolFoundFiles.Count > 0 Then
                                mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound), Before:=1
                            Else
                                mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound)
                            End If
                        End If
                        aFiles(1, lngFound) = vbNullString
                    End If
                Loop
            Case MsoSortBy.msoSortByLastModified
                lngFound = 0
                Do While lngFound > -1
                    lngFound = -1
                    dtFoundItem = #12/31/2999#
                    For i = 0 To mlngFilesIX
                        If aFiles(3, i) > 0 Then
                            If CDate(aFiles(3, i)) < dtFoundItem Then
                                dtFoundItem = CDate(aFiles(3, i))
                                lngFound = i
                            End If
                        End If
                    Next i
                    If lngFound > -1 Then
                        If mobjSortOrder = msoSortOrderAscending Then
                            mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound)
                        Else
                            If mcolFoundFiles.Count > 0 Then
                                mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound), Before:=1
                            Else
                                mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound)
                            End If
                        End If
                        aFiles(3, lngFound) = 0
                    End If
                Loop
            Case MsoSortBy.msoSortByNone
                For i = 0 To mlngFilesIX
                    mcolFoundFiles.Add aFiles(0, i) & "\" & aFiles(1, lngFound)
                Next i
            Case MsoSortBy.msoSortBySize
                lngFound = 0
                Do While lngFound > -1
                    lngFound = -1
                    lngFoundItem = #12/31/2999#
                    For i = 0 To mlngFilesIX
                        If aFiles(4, i) > -1 Then
                            If CLng(aFiles(4, i)) < lngFoundItem Then
                                lngFoundItem = CLng(aFiles(4, i))
                                lngFound = i
                            End If
                        End If
                    Next i
                    If lngFound > -1 Then
                        If mobjSortOrder = msoSortOrderAscending Then
                            mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound)
                        Else
                            If mcolFoundFiles.Count > 0 Then
                                mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound), Before:=1
                            Else
                                mcolFoundFiles.Add aFiles(0, lngFound) & "\" & aFiles(1, lngFound)
                            End If
                        End If
                        aFiles(4, lngFound) = -1
                    End If
                Loop
        End Select
    End If
    
End Sub

Private Sub SetFileTypes()

    Select Case meFileType

        Case msoFileTypeAllFiles

        Case msoFileTypeOfficeFiles

        Case msoFileTypeWordDocuments

        Case msoFileTypeExcelWorkbooks

        Case msoFileTypePowerPointPresentations

        Case msoFileTypeDatabases
        
        'Case msoFileTypeTemplates, msoFileTypeBinders, msoFileTypeOutlookItems, msoFileTypeMailItem, _
            msoFileTypeCalendarItem, msoFileTypeContactItem, msoFileTypeNoteItem, msoFileTypeJournalItem, _
            msoFileTypeTaskItem, msoFileTypePhotoDrawFiles, msoFileTypeDataConnectionFiles, _
            msoFileTypePublisherFiles, msoFileTypeProjectFiles, msoFileTypeDocumentImagingFiles, _
            msoFileTypeVisioFiles, msoFileTypeDesignerFiles, msoFileTypeWebPages
        Case Else
        
    End Select

End Sub

Open in new window


Add references in your VBA project to Microsoft Scritping Runtime, Microsoft VBScript Regular Expressions 5.5, and Microsoft Office 12.0 Object Library
Change your code as follows to create an instance of the new class and use it.  You should not have to change any of your other code. 
Private Sub FichImporte_GotFocus()
Dim CSql As String
Dim rst As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim intLenRep As Integer
Dim intLen As Integer
Dim cnn As Object
Dim stRepCh As String
Dim stFichier As String
Dim i As Long

' declare the new FileSearch Class
Dim FS As New clsFileSearch

Set cnn = CurrentProject.Connection

intLenRep = Len(stRepCh)

    cnn.Execute "DELETE FROM FICHIERS_TROUVES"

    Set rst = New ADODB.Recordset
    Set rs1 = New ADODB.Recordset

    'Active la connection de la base Access
    Set rst.ActiveConnection = cnn
    CSql = "FICHIERS_TROUVES;"

    'Ouvre le recordset qui correspond à la table ci-dessous.
    rst.Open CSql, , adOpenKeyset, adLockOptimistic

    ' use the user written class rather than the old FileSearch
    With FS
        'Débute une nouvelle recherche
        .NewSearch
        'Définit les critères de recherche
        .LookIn = stRepCh
        .FileName = "*.*"
        .SearchSubFolders = True
    End With


With Application.FileSearch
    'Exécute la recherche
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                'TextBox.Value = .FoundFiles(i)
                intLen = Len(.FoundFiles(i))
                stFichier = Right(.FoundFiles(i), intLen - intLenRep)
                'Call ShowFileInfo(.FoundFiles(i))
                With rst
                    If Right(stFichier, 11) <> "_traite.xls" Then
                        .AddNew
                            .Fields(1) = stFichier
                            '.Fields(2) = s
                        .Update
                    End If
                End With
                
                
            Next i
        End If
End With
        FichImporte.Requery

End Sub

Open in new window

VBAlearner2010

Author

Commented:
Thank you MINDSUPERB

Thank You RORYA

Thank you andrewssd3.


I am changing the code to see if it works.. Will keep you posted on the result shortly.
VBAlearner2010

Author

Commented:
@andrewssd3 i have added reference as you said and added the code in the new class module... But i see lots of red lines in the code.. Can you see if you have missed any syntax for the class module and confirm me. I am very new to coding and and i am stuck now...

Also it could be helpful to know how to call the class module in the second coding part.

Thanks in advance for your help.
VBAlearner2010

Author

Commented:
@rorya
 
I have declared stFichier as Filesystemobject

Still i get the below part of code in red colour starting from Dowhile.. Can you help?  



stFichier = Dir(stRepCh & "*.*")
   Do While stFichier <> ""
      With rst
         If Right(stFichier, 11) <> "_traite.xls" Then
            .AddNew
            .Fields(1) = stFichier
            '.Fields(2) = s
            .Update
         End If
      End With
      stFichier = Dir
   Loop

Open in new window

Rory Archibald
CERTIFIED EXPERT
Most Valuable Expert 2011
Top Expert 2011

Commented:
>>"I have declared stFichier as Filesystemobject"

Why? It's a String just as it was before.
VBAlearner2010

Author

Commented:
Dint had the same result even before i declared. Kindly check and tel me what could be the problem.
Rory Archibald
CERTIFIED EXPERT
Most Valuable Expert 2011
Top Expert 2011

Commented:
Just tested quickly and it works fine for me - there's certainly nothing syntactically wrong with it. What error are you getting?
Rory Archibald
CERTIFIED EXPERT
Most Valuable Expert 2011
Top Expert 2011

Commented:
PS Not really sure what you mean by "Dint".
VBAlearner2010

Author

Commented:
Oh I am sorry Rorya.. It was a typo. I am using french keyboard and english keyboard alternatively which is confusing me.

Regarding the error you said I get red lines on the code. I am retyping it instead of copy paste. WIll let you know shortly on the result.
VBAlearner2010

Author

Commented:
It looks fine rorya.. Thank you.. But i have not checked the output yet.. Will keep you posted.
VBAlearner2010

Author

Commented:
@andrewssd3 : Your class and solutioon is really amazing.. I have corrected the red lines now.. I will have to check the whole functionality witht the code and keep you posted on it. And thanks a ton for this wonderful code.. I am confident that it will work wonders for me.
andrewssd3
Top Expert 2011

Commented:
Thanks - it does not do absolutely everything you could do with Fileseach, but it did work for all the cases that were actrually being used in my company - most people just use it like you to retrieve a list of files of by certain criteria.
VBAlearner2010

Author

Commented:
Perfect solutions by Rorya and andrewssd3
VBAlearner2010

Author

Commented:
@andrewssd3: One more help on the same thread. Could you please simply your class only for Application.Flesearch alone and send me.

I would be of great help if you do that for me.

If i put all the functionalities of File search they dont need. So please simplify your class just for Application.filesearch.

I have to replace the below code now.
Function LastFileSaved(sFileDir As String, DebutNomFichier As String, Optional sType As String = "*.*") As String

Dim fs
Set fs = Application.FileSearch
With fs
    .LookIn = sFileDir
    .Filename = DebutNomFichier
    
    If .Execute(SortBy:=msoSortByLastModified, _
        SortOrder:=msoSortOrderDescending) > 0 Then
        LastFileSaved = .FoundFiles(1)
    Else
        MsgBox "There were no files found in:" & vbLf & _
        sFileDir & vbLf & _
        "Type: " & sType
      LastFileSaved = vbNullString
    End If
End With

End Function

Open in new window

andrewssd3
Top Expert 2011

Commented:
You should really post this as a new question, but I can't really simplify the code - it would be difficult to pull out some of the properties and methods and leave the others.  It's just the same principle as before - add the clsFileSearch, add the references, the change the code you posted very simply like this:
Function LastFileSaved(sFileDir As String, DebutNomFichier As String, Optional sType As String = "*.*") As String

Dim fs As clsFileSearch               ' CHANGED LINE
Set fs = new clsFileSearch          'CHANGED LINE
With fs
    .LookIn = sFileDir
    .Filename = DebutNomFichier
    
    If .Execute(SortBy:=msoSortByLastModified, _
        SortOrder:=msoSortOrderDescending) > 0 Then
        LastFileSaved = .FoundFiles(1)
    Else
        MsgBox "There were no files found in:" & vbLf & _
        sFileDir & vbLf & _
        "Type: " & sType
      LastFileSaved = vbNullString
    End If
End With

End Function

Open in new window

It's just 2 lines to change.  If you need a specific code solution for this instance, like the one rorya provided earlier, you really must raise a new question, and I'm sure someone (maybe even me) will oblige.  My code was meant to be generic, so it's necessarily relatively complex.
VBAlearner2010

Author

Commented:
andrewssd3:Thank you very much. I will definetely raise it as new question from now.. I am new to this forum so i did not understand it...

Anyways thank you so much. It helped a lot.