Recherche fichiers dans sous repertoire
Bonsoir,
Etant complètement novice, j'aurais besoin d'un coup de main pour finir un projet.
Donc si quelqu'un pourrais aider un pauvre naufragé du code VB ?
Je résume ce que je souhaite :
1- Je tape un nom de fichier (ex : 658794) dans ma TextBox
2- J'appui sur le bouton "Find"
3- Les fichiers qui correspondent (658794, 658794 -1, 658794-2, 658794-3) qui sont dans différents répertoires et sous répertoires dont la racine commune est : c:\test\draw s'affiche dans la ListBox et non pas un listage de tous les fichiers qui sont dans c:\test\draw\... .
4- Je sélectionne un des fichier dans la ListBox
5- J'appui sur le bouton ouvrir et le fichier sélectionné s'ouvre.
Pour l'instant, la partie 5 fonctionne parfaitement.
Après être parti dans tous les sens, je pense avoir un truc un peu près propre et enfin presque toucher au but.
Mais :
- premier problème, ma recherche de fichier par ex : 658794 ne me donne comme résultat dans la ListBox que :658794 mais pas ceux nommés 658794-2, 658794-3
- second problème, ma recherche s’arrête au 1er niveau, dans : c:\test\draw mais ne va pas chercher plus loin alors qu'il y a encore d'autres sous répertoire (ex : c:\test\draw\65-45896\ ).
En espérant ne pas vous avoir perdu, j'en appelle à toutes les bonnes âmes du VB pour m'aider.
merci.
PS: voila mon fichier et code pour vous donner une idée d'ou j'en suis.
Option Explicit
Dim fichier As String
Dim fichier2 As String
Dim Flder As Object
Dim comp As String
Const boite = vbOKOnly + vbInformationPrivate Sub Explorer_Click()
Dim MonDossier As String
MonDossier = "C:\test"
Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbNormalFocus
End Sub
Private Sub Find_Click()
Dim fso As Object
Dim Dossier As Object
Dim LeDossier As String
Dim chemin As String
comp = TextBox1.Value
LeDossier = "C:\test"
Set fso = CreateObject("scripting.FileSystemObject")
Set Dossier = fso.getfolder(LeDossier)
For Each Flder In Dossier.subfolders
fichier = Dir(Flder.Path & Application.PathSeparator & comp & ".pdf")
If fichier <> "" Then '
chemin = Flder.Path & Application.PathSeparator
Exit For
End If
Next Flder
If fichier = "" Then
MsgBox "le fichier n'existe pas", vbInformation + vbOKOnly, "ERREUR"
Else
fichier = chemin & comp & ".pdf"
UserForm1.ListBox1.AddItem fichier
End If
End Sub
Private Sub Ouvrir_Click()
Dim sFichier As String, WsShell As Object
sFichier = Me.ListBox1.List(ListBox1.ListIndex)
If Len(sFichier) = 0 Then Exit Sub
Set WsShell = CreateObject("WScript.Shell")
WsShell.Run "AcroRd32 " & sFichier
Set WsShell = Nothing
End Sub
Private Sub Quitter_Click()
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
End SubPersonne pour m'aider a corriger mes erreurs ?
Bonjour,
Tout d'abords, quand tu postes un classeur exemple ici, il est préférable d'éviter de cacher l'application, de modifier les barres d'outils, etc...
premier problème, ma recherche de fichier par ex : 658794 ne me donne comme résultat dans la ListBox que :658794 mais pas ceux nommés 658794-2, 658794-3
Si tu veux faire une recherche sur une partie du nom, utilise l'astérisque (*) donc, la ligne :
comp = TextBox1.Valuedevient :
comp = TextBox1.Value & "*"second problème, ma recherche s’arrête au 1er niveau, dans : c:\test\draw mais ne va pas chercher plus loin alors qu'il y a encore d'autres sous répertoire (ex : c:\test\draw\65-45896\ ).
Pour ça, la recherche doit être récursive (elle s'appelle elle-même). Je te re-poste tout le code du formulaire car modif à plusieurs endroits :
'code à coller dans le module de l'UserForm
Dim TblFichiers() As String
Dim Racine As Boolean
Private Sub Explorer_Click()
Dim MonDossier As String
MonDossier = "C:\test"
Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbNormalFocus
End Sub
Private Sub Find_Click()
Dim LeDossier As String
Dim J As Long
Dim Comp As String
'ici sont rajouté l'astérisque et l'extension
Comp = TextBox1.Value & "*.pdf"
LeDossier = "C:\test"
'mets à vrai pour ne pas récupérer deux fois les mêmes fichiers
Racine = True
'appel de la Sub récursive qui va remplir le tableau
RecupFichiers LeDossier, Comp
'inscription des fichiers dans la ListBox avec le chemin complet
For J = 1 To UBound(TblFichiers())
ListBox1.AddItem TblFichiers(J)
Next J
'vide le tableau
Erase TblFichiers()
End Sub
Private Sub Ouvrir_Click()
Dim sFichier As String, WsShell As Object
sFichier = Me.ListBox1.List(ListBox1.ListIndex)
If Len(sFichier) = 0 Then Exit Sub
Set WsShell = CreateObject("WScript.Shell")
WsShell.Run "AcroRd32 " & sFichier
Set WsShell = Nothing
End Sub
Private Sub Quitter_Click()
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
End Sub
'procédure récursive
Sub RecupFichiers(Dossier As String, NomFichier As String)
Dim FSO As Object
Dim Dos As Object
Dim Fichier As Object
Static I As Integer
Static DossierRacine As String
'supprime le "\" de fin
If Right(Dossier, 1) = "\" Then Dossier = Left(Dossier, Len(Dossier) - 1)
If DossierRacine = "" Then DossierRacine = Dossier
'crée l'objet FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
'si c'est le dossier racine
If Racine = True Then
'récupère les fichiers contenus dans le dossier racine
For Each Fichier In FSO.GetFolder(Dossier).Files
If Fichier Like NomFichier Then
I = I + 1
ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Dossier & "\" & Fichier.Name
End If
Next Fichier
Racine = False
End If
'boucle sur les dossiers
For Each Dos In FSO.GetFolder(Dossier).SubFolders
'évite l'erreur des fichiers interdits
On Error Resume Next
'récupère les fichiers contenus dans le dossier en cours
For Each Fichier In Dos.Files
If Fichier Like "*.pdf" Then
I = I + 1
ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Dossier & "\" & Fichier.Name
End If
Next Fichier
'rappel de la proc pour chercher les dossiers enfants (récursivité)
RecupFichiers Dossier & "\" & Dos.Name, NomFichier
Next Dos
End SubMerci beaucoup pour le coup de main.
Mais là que je tape "coucou" ou "658794", le résultat dans la ListBox est un listing de tous les fichiers contenu dans c:\test\...
En revanche il cherche bien dans tous les répertoires et sous répertoire.
Une idée ?
Re,
Je suis allé un peu trop vite et quelques erreurs dan mon premier code. Teste celui-ci :
Dim TblFichiers() As String
Dim Racine As Boolean
Private Sub Find_Click()
Dim LeDossier As String
Dim J As Long
Dim Comp As String
Dim Extension As String
Comp = TextBox1.Value
Extension = ".pdf"
LeDossier = "C:\Test"
'mets à vrai pour ne pas récupérer deux fois les mêmes fichiers
Racine = True
'appel de la Sub récursive qui va remplir le tableau
RecupFichiers LeDossier, Comp, Extension
'inscription des fichiers dans la ListBox avec le chemin complet
For J = 1 To UBound(TblFichiers())
ListBox1.AddItem TblFichiers(J)
Next J
'vide le tableau
Erase TblFichiers()
End Sub
Sub RecupFichiers(Dossier As String, NomFichier As String, ext As String)
Dim FSO As Object
Dim Dos As Object
Dim Fichier As Object
Static I As Integer
Static DossierRacine As String
'supprime le "\" de fin
If Right(Dossier, 1) = "\" Then Dossier = Left(Dossier, Len(Dossier) - 1)
If DossierRacine = "" Then DossierRacine = Dossier
'crée l'objet FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
'si c'est le dossier racine
If Racine = True Then
'récupère les fichiers contenus dans le dossier racine
For Each Fichier In FSO.GetFolder(Dossier).Files
If Dir(Fichier) Like NomFichier & "*" & ext Then
I = I + 1
ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Fichier
End If
Next Fichier
Racine = False
End If
'boucle sur les dossiers
For Each Dos In FSO.GetFolder(Dossier).SubFolders
'évite l'erreur des fichiers interdits
On Error Resume Next
'récupère les fichiers contenus dans le dossier en cours
For Each Fichier In Dos.Files
If Dir(Fichier) Like NomFichier & "*" & ext Then
I = I + 1
ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Fichier
End If
Next Fichier
'rappel de la proc pour chercher les dossiers enfants (récursivité)
RecupFichiers Dossier & "\" & Dos.Name, NomFichier, ext
Next Dos
End Subj'ai une erreur : erreur de compilation variable non définie
puis marqueur sur la ligne du premier : ReDim Preserve TablFichiers(1 To
Vraiment très gentil de m'aider à me sortir la tête de l'eau.
Re,
Cette ligne :
Dim TblFichiers() As Stringest bien en tête du module de la Form ?
oui.
EDIT : excuse moi, lignes présente mais pas en tête.
TOUT marche, merci, merci, merci beaucoup.
vraiment merci pour toute l'aide que tu m'as apporté.
Me reste plus qu'a intégrer : MsgBox "il n'y a pas de PDF dans ce dossier et ses sous dossiers ", vbInformation + vbOKOnly, "ERREUR"
si le nom de fichier n'existe pas.
encore merci.
Bon, je suis vraiment assisté,
ton code est plus compliqué que ce que je pensais, j'ai du mal à suivre. Du coup l'entrée facile :
If fichier = "" Then
MsgBox "le fichier n'existe pas", vbInformation + vbOKOnly, "ERREUR"
je n'arrive pas à l'adapter au contexte (J=, to unbound, tablfichiers ...)
J'avoue que c'est abusé et que on dirait un flemmard qui ne cherche pas a comprendre, mais ça fait 2 semaines que je tourne en rond sur cet Userform et j'ai l'impression de comprendre de moins en moins de chose.
Bonjour,
Je te re-poste juste les deux procédures car j'ai fais une modif dans les deux. La procédure évènementielle "Click" pour ce que tu demande et la procédure de recherche pour gérer l'abcsence du dossier :
Private Sub Find_Click()
Dim LeDossier As String
Dim J As Long
Dim Comp As String
Dim Extension As String
Dim Test As Long
Comp = TextBox1.Value
Extension = ".pdf"
LeDossier = "C:\Test"
'mets à vrai pour ne pas récupérer deux fois les mêmes fichiers
Racine = True
'appel de la Sub récursive qui va remplir le tableau
RecupFichiers LeDossier, Comp, Extension
On Error Resume Next
Test = UBound(TblFichiers())
If Err.Number <> 0 Then
MsgBox "le fichier n'existe pas", vbInformation + vbOKOnly, "ERREUR"
Else
'inscription des fichiers dans la ListBox avec le chemin complet
For J = 1 To Test
ListBox1.AddItem TblFichiers(J)
Next J
End If
'vide le tableau
Erase TblFichiers()
End Sub
Sub RecupFichiers(Dossier As String, NomFichier As String, ext As String)
Dim FSO As Object
Dim Dos As Object
Dim Fichier As Object
Static I As Integer
Static DossierRacine As String
'supprime le "\" de fin
If Right(Dossier, 1) = "\" Then Dossier = Left(Dossier, Len(Dossier) - 1)
If DossierRacine = "" Then DossierRacine = Dossier
'crée l'objet FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
'si le dossier n'existe pas, fin
If FSO.FolderExists(Dossier) = False Then Exit Sub '<-- rajout ici !
'si c'est le dossier racine
If Racine = True Then
'récupère les fichiers contenus dans le dossier racine
For Each Fichier In FSO.GetFolder(Dossier).Files
If Dir(Fichier) Like NomFichier & "*" & ext Then
I = I + 1
ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Fichier
End If
Next Fichier
Racine = False
End If
'boucle sur les dossiers
For Each Dos In FSO.GetFolder(Dossier).SubFolders
'évite l'erreur des fichiers interdits
On Error Resume Next
'récupère les fichiers contenus dans le dossier en cours
For Each Fichier In Dos.Files
If Dir(Fichier) Like NomFichier & "*" & ext Then
I = I + 1
ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Fichier
End If
Next Fichier
'rappel de la proc pour chercher les dossiers enfants (récursivité)
RecupFichiers Dossier & "\" & Dos.Name, NomFichier, ext
Next Dos
End SubBonjour,
merci pour la V2.
Tout fonctionne bien, j'ai déployé le fichier aujourd'hui et impeccable ça marche bien et j'en suis super satisfait.
En revanche, suite au à 'excellent boulot de ce fichier, j'ai voulu le détourner et m'en servir en réseau, mais
que la recherche est lente. (bon ok, environs 25000 pdf enfermer dans environs 30 sous répertoire) est- ce normal ?
Je commence a comprendre ton code ( son architecture) en m'aidant de mon petit bouquin excel mais pas forcément encore très naturel pour moi.
merci.
Bonjour,
Regardes du coté des APIs Windows, c'est probablement plus rapide
Bonjour,
Voila, j'ai enfin réussi à obtenir ce que je voulais exactement :
chercher des PDF dans des répertoires et sous répertoire, avoir un aperçu une fois sélectionné dans la ListBox et pouvoir ouvrir le fichier en double-cliquant sur son nom.
Cela parait surement très simple pour des habitués, mais pour moi cela à été 1 mois de recherches, de test, d'appel au secours ...
Du coup je laisse mon fichier en pièce jointe, il pourra peut-être servir a des novices comme moi (une sorte de contribution).
Sinon voici le code complet au cas ou des pro relèverais des erreurs voir même l'optimiser peut-être.
Option Explicit
Dim fso As Object
Dim fld As Object
Private Function TrouveFichiers(ByVal sFol As String, sFile As String, _
NbRep As Long, NbFichiers As Long) As Currency
Dim tFld, NomFichier As String
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
NomFichier = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(NomFichier) <> 0
TrouveFichiers = TrouveFichiers + FileLen(fso.BuildPath(fld.Path, _
NomFichier))
NbFichiers = NbFichiers + 1
ListBox1.AddItem fso.BuildPath(fld.ShortPath, NomFichier)
'ou ListBox1.AddItem NomFichier 'uniquement le nom des fichiers
NomFichier = Dir()
DoEvents
Wend
Label1 = "Recherche " & vbCrLf & fld.Path & "..."
NbRep = NbRep + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
TrouveFichiers = TrouveFichiers + TrouveFichiers(tFld.Path, sFile, NbRep, NbFichiers)
Next
End If
Exit Function
Catch: NomFichier = ""
Resume Next
End Function
Private Sub Find_Click()
Dim NbRep As Long, NbFichiers As Long, NbBytes As Currency
Dim Depart As String, Extension As String
ListBox1.Clear
Depart = "C:\test\"
Extension = TextBox1.Value & "*.pdf"
Label1.Caption = "Recherche " & vbCrLf & UCase(Depart) & "..."
NbBytes = TrouveFichiers(Depart, Extension, NbRep, NbFichiers)
MsgBox Str(NbFichiers) & " Fichiers trouvés ", vbInformation
If NbBytes = "0" Then
End If
End Sub
Private Sub Explorer_Click()
Dim MonDossier As String
MonDossier = "C:\test\"
Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbNormalFocus
End Sub
Private Sub ListBox1_Click()
WebBrowser1.Navigate Me.ListBox1.List(ListBox1.ListIndex)
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim sFichier As String, WsShell As Object
Dim MSG As String
If IsNull(ListBox1) Then
MSG = MsgBox("Veuillez sélectionner un fichier")
Else
sFichier = Me.ListBox1.List(ListBox1.ListIndex)
If Len(sFichier) = 0 Then Exit Sub
Set WsShell = CreateObject("WScript.Shell")
WsShell.Run "AcroRd32 " & sFichier
Set WsShell = Nothing
End If
End Sub
Private Sub Quitter_Click()
ThisWorkbook.Saved = True
ThisWorkbook.Close
End SubMerci à tous et bonne année.
Gros déterrage mais un énorme merci pour ton code minifrix, il m'a servit à construire le miens, je faisais une recherche dans le même genre mais elle était 2 fois plus lente, ton code m'a permis d’accélérer mon programme, toujours sympa de partager le final