Patricia37
XLDnaute Nouveau
Bonjour,
J'utilise le code ci-dessous pour effectuer une recherche documentaire. Bien que cela fonctionne, c'est extrêmement lent (environ 1 minute pour avoir le résultat). Est-il possible d'améliorer la séquence ou peut-etre y-a-t-il d'autres fonctions plus adaptées ?
Je ne maitrise pas du tout VBA, j'utilise un fichier disponible en interne ... Merci de votre aide !
Option Explicit
Option Compare Text
'Modif 2007
Sub RechercheFichiers(ByRef poDossier As Scripting.Folder, ByRef piLigne As Integer, ByRef psArray() As String, ByRef psChaine As String)
Dim oD As Scripting.Folder, oF As Scripting.File
For Each oF In poDossier.Files
If UCase(oF.Name) Like "*" & UCase(psChaine) & "*" Then
ReDim Preserve psArray(piLigne)
' ActiveSheet.Cells(piLigne + 7, 5) = oF.Path
psArray(piLigne) = oF.Path
piLigne = piLigne + 1
End If
Next
For Each oD In poDossier.SubFolders
RechercheFichiers oD, piLigne, psArray(), psChaine
Next
End Sub
'fin Modif 2007
Function Recherche(psChaine As String) As Integer
Dim oFSO As Scripting.FileSystemObject
Dim sArray() As String, iLigne As Integer, oDossierRacine As Scripting.Folder
'Application.FileSearch KO 'nécessite Référence Microsoft Office Object Library
'L'objet FileSearch permet de rechercher des documents sur n'importe quel disque de l'ordinateur. KO Office 2007 !
'Il utilise le mécanisme de recherche propre à Windows ce qui en fait un outil puissant
Dim iCpt As Integer
Dim sChemin As String, sNomFic As String
Recherche = 0
On Error GoTo Erreur
iLigne = 0
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDossierRacine = oFSO.GetFolder(Parametres.g_sRepsource)
Call RechercheFichiers(oDossierRacine, iLigne, sArray(), psChaine)
Set oFSO = Nothing
Set oDossierRacine = Nothing
' FormulaireCherche.ListBox_Fichier.Clear
' With Application.FileSearch
' ..NewSearch
' .RefreshScopes
' 'Dossier(s) de recherche :
' .LookIn = Parametres.g_sRepsource '"D:\PROJET GEDOC\DEMARCHE QUALITE"
' 'on recherche tous les fichiers qui contiennent psChaine (saisie dans la zone de texte de l'onglet QUALIDOC)
' 'quel que part dans leur nom
' .Filename = "*" & psChaine & "*"
' ..FileType = msoFileTypeAllFiles
' ..SearchSubFolders = True
' ..Execute
If iLigne = 0 Then
MsgBox "Aucun fichier contenant la chaine " & """" & psChaine & """" & " n'a été trouvé", vbInformation + vbOKOnly, "Application GEDOC"
Else
For iCpt = 0 To iLigne - 1
Call SeparerChemin_Fic(sArray(iCpt), sChemin, sNomFic)
FormulaireCherche.ListBox_Fichier.AddItem
FormulaireCherche.ListBox_Fichier.List(iCpt, 0) = sChemin
FormulaireCherche.ListBox_Fichier.List(iCpt, 1) = sNomFic
Next
If iLigne = 1 Then
FormulaireCherche.lbl_NbFicTrouve.Caption = "1 fichier contenant la chaine " & """" & psChaine & """" & " a été trouvé"
Else
FormulaireCherche.lbl_NbFicTrouve.Caption = iLigne & " fichiers contenant la chaine " & """" & psChaine & """" & " ont été trouvés"
End If
FormulaireCherche.Show (0)
End If
' End With
Recherche = 1
Exit Function
Erreur:
End Function
Sub SeparerChemin_Fic(psFicTrouve As String, ByRef psChemin As String, ByRef psNomFic As String)
psNomFic = Mid(psFicTrouve, InStrRev(psFicTrouve, "\") + 1, Len(psFicTrouve))
psChemin = Mid(psFicTrouve, 1, InStrRev(psFicTrouve, "\"))
End Sub
J'utilise le code ci-dessous pour effectuer une recherche documentaire. Bien que cela fonctionne, c'est extrêmement lent (environ 1 minute pour avoir le résultat). Est-il possible d'améliorer la séquence ou peut-etre y-a-t-il d'autres fonctions plus adaptées ?
Je ne maitrise pas du tout VBA, j'utilise un fichier disponible en interne ... Merci de votre aide !
Option Explicit
Option Compare Text
'Modif 2007
Sub RechercheFichiers(ByRef poDossier As Scripting.Folder, ByRef piLigne As Integer, ByRef psArray() As String, ByRef psChaine As String)
Dim oD As Scripting.Folder, oF As Scripting.File
For Each oF In poDossier.Files
If UCase(oF.Name) Like "*" & UCase(psChaine) & "*" Then
ReDim Preserve psArray(piLigne)
' ActiveSheet.Cells(piLigne + 7, 5) = oF.Path
psArray(piLigne) = oF.Path
piLigne = piLigne + 1
End If
Next
For Each oD In poDossier.SubFolders
RechercheFichiers oD, piLigne, psArray(), psChaine
Next
End Sub
'fin Modif 2007
Function Recherche(psChaine As String) As Integer
Dim oFSO As Scripting.FileSystemObject
Dim sArray() As String, iLigne As Integer, oDossierRacine As Scripting.Folder
'Application.FileSearch KO 'nécessite Référence Microsoft Office Object Library
'L'objet FileSearch permet de rechercher des documents sur n'importe quel disque de l'ordinateur. KO Office 2007 !
'Il utilise le mécanisme de recherche propre à Windows ce qui en fait un outil puissant
Dim iCpt As Integer
Dim sChemin As String, sNomFic As String
Recherche = 0
On Error GoTo Erreur
iLigne = 0
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDossierRacine = oFSO.GetFolder(Parametres.g_sRepsource)
Call RechercheFichiers(oDossierRacine, iLigne, sArray(), psChaine)
Set oFSO = Nothing
Set oDossierRacine = Nothing
' FormulaireCherche.ListBox_Fichier.Clear
' With Application.FileSearch
' ..NewSearch
' .RefreshScopes
' 'Dossier(s) de recherche :
' .LookIn = Parametres.g_sRepsource '"D:\PROJET GEDOC\DEMARCHE QUALITE"
' 'on recherche tous les fichiers qui contiennent psChaine (saisie dans la zone de texte de l'onglet QUALIDOC)
' 'quel que part dans leur nom
' .Filename = "*" & psChaine & "*"
' ..FileType = msoFileTypeAllFiles
' ..SearchSubFolders = True
' ..Execute
If iLigne = 0 Then
MsgBox "Aucun fichier contenant la chaine " & """" & psChaine & """" & " n'a été trouvé", vbInformation + vbOKOnly, "Application GEDOC"
Else
For iCpt = 0 To iLigne - 1
Call SeparerChemin_Fic(sArray(iCpt), sChemin, sNomFic)
FormulaireCherche.ListBox_Fichier.AddItem
FormulaireCherche.ListBox_Fichier.List(iCpt, 0) = sChemin
FormulaireCherche.ListBox_Fichier.List(iCpt, 1) = sNomFic
Next
If iLigne = 1 Then
FormulaireCherche.lbl_NbFicTrouve.Caption = "1 fichier contenant la chaine " & """" & psChaine & """" & " a été trouvé"
Else
FormulaireCherche.lbl_NbFicTrouve.Caption = iLigne & " fichiers contenant la chaine " & """" & psChaine & """" & " ont été trouvés"
End If
FormulaireCherche.Show (0)
End If
' End With
Recherche = 1
Exit Function
Erreur:
End Function
Sub SeparerChemin_Fic(psFicTrouve As String, ByRef psChemin As String, ByRef psNomFic As String)
psNomFic = Mid(psFicTrouve, InStrRev(psFicTrouve, "\") + 1, Len(psFicTrouve))
psChemin = Mid(psFicTrouve, 1, InStrRev(psFicTrouve, "\"))
End Sub
