Option Explicit
Option Compare Text
#If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#Else
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#End If
Sub Main_Ultime()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim i As Long
Dim DossierRacine As String
Dim DossierCherche As String
Dim TableauResultats As Variant
'
' Compteurs haute précision
Dim freq As Currency, startCount As Currency, endCount As Currency
Dim elapsed As Double
Dim msgTemps As String
Dim mins As Long
Dim secs As Double
QueryPerformanceFrequency freq
QueryPerformanceCounter startCount
'
Set F1 = Worksheets(ActiveSheet.Name)
DossierRacine = F1.Cells(1, 1).Value
DossierCherche = F1.Cells(20, 1).Value
'
' Nettoyage
F1.Range(F1.Cells(1, 2), F1.Cells(F1.Range("B65536").End(xlUp).Row, 2)).Clear
'
' ---------------------------------------------------------
' APPEL DE LA FONCTION ULTIME
' Retourne directement un Tableau (Variant) et non une Collection
' ---------------------------------------------------------
TableauResultats = Chercheur_Dir_Dictionary(DossierRacine, DossierCherche)
'
' --- RESTITUTION ---
'
' Gestion du tableau vide (si non trouvé)
If Not IsArray(TableauResultats) Then
F1.Cells(1, 2).Value = "Non trouvé"
F1.Cells(1, 2).Interior.Color = vbRed
Else
' Si un seul résultat (UBound est à 0)
If UBound(TableauResultats) = 0 Then
F1.Hyperlinks.Add Anchor:=F1.Cells(1, 2), Address:=TableauResultats(0), TextToDisplay:=TableauResultats(0)
F1.Cells(1, 2).Interior.Color = vbGreen
Shell "explorer.exe " & Chr(34) & TableauResultats(0) & Chr(34), vbNormalFocus
Else
' Cas multiple
F1.Cells(1, 2).Value = "Il y a " & (UBound(TableauResultats) + 1) & " dossiers identiques :"
F1.Cells(1, 2).Interior.Color = vbYellow
F1.Cells(1, 2).Font.Bold = True
' Boucle sur le tableau (Index commence à 0)
For i = LBound(TableauResultats) To UBound(TableauResultats)
' On décale de 1 ligne pour le titre
F1.Hyperlinks.Add Anchor:=F1.Cells(i + 2, 2), Address:=TableauResultats(i), TextToDisplay:=TableauResultats(i)
F1.Cells(i + 2, 2).Interior.Color = RGB(220, 240, 220)
' Ouverture auto du premier
If i = 0 Then Shell "explorer.exe " & Chr(34) & TableauResultats(0) & Chr(34), vbNormalFocus
Next i
End If
End If
'
F1.Columns("B").AutoFit
Application.ScreenUpdating = True
' ---------------------------------------------------------
' FIN DE MESURE ET CONVERSION INTELLIGENTE
' ---------------------------------------------------------
QueryPerformanceCounter endCount
' Calcul du temps en Millisecondes
elapsed = (endCount - startCount) / freq * 1000
' Formatage du message selon la durée
If elapsed < 1000 Then
' Moins d'une seconde : on affiche en ms
msgTemps = Format(elapsed, "0.000") & " millisecondes"
ElseIf elapsed < 60000 Then
' Moins d'une minute : on affiche en secondes
msgTemps = Format(elapsed / 1000, "0.000") & " secondes"
Else
' Plus d'une minute : on affiche minutes et secondes
mins = Int(elapsed / 60000)
secs = (elapsed - (mins * 60000)) / 1000
msgTemps = mins & " minute(s) et " & Format(secs, "0.00") & " secondes"
End If
MsgBox "La Recherche a été exécutée en " & msgTemps, vbInformation, "Performance ULTIME"
End Sub
' ---------------------------------------------------------
' FONCTION ULTIME : DIR + PILE + DICTIONARY
' ---------------------------------------------------------
Function Chercheur_Dir_Dictionary(Racine As String, NomRecherche As String) As Variant
Dim Pile As New Collection ' La pile pour stocker les dossiers à scanner
Dim Dict As Object ' Le Dictionary pour stocker les résultats
Dim CheminEnCours As String ' Le dossier en cours de lecture
Dim Element As String ' L'élément trouvé par Dir
Dim CheminComplet As String
'
Set Dict = CreateObject("Scripting.Dictionary")
'
' Normalisation du chemin racine
If Right(Racine, 1) <> "\" Then Racine = Racine & "\"
' 1. On met le dossier racine dans la pile
Pile.Add Racine
' 2. BOUCLE ITERATIVE (Plus rapide que la récursivité pour Dir)
Do While Pile.Count > 0
' On prend le premier de la pile
CheminEnCours = Pile(1)
Pile.Remove 1
' ---------------------------------------------------------
' CORRECTION DU PLANTAGE ICI AVEC RACINE C:\
' On protège l'appel initial de Dir car c'est là que ça plante
' sur les dossiers systèmes (PerfLogs, System Volume Information...)
' ---------------------------------------------------------
On Error Resume Next
' On lance Dir pour ce dossier (vbDirectory pour voir les dossiers)
Element = Dir(CheminEnCours & "*", vbDirectory)
' Si erreur (ex: Accès refusé), Err.Number > 0
If Err.Number <> 0 Then
' On ignore ce dossier, on vide l'erreur, et on passe au suivant dans la Pile
Err.Clear
On Error GoTo 0
GoTo ContinueLoop ' Saut vers la fin de la boucle Do
End If
On Error GoTo 0
' ---------------------------------------------------------
Do While Element <> ""
' On ignore les dossier système . et ..
If Element <> "." And Element <> ".." Then
CheminComplet = CheminEnCours & Element
' On teste si c'est un dossier (GetAttr est natif et rapide)
On Error Resume Next
If (GetAttr(CheminComplet) And vbDirectory) = vbDirectory Then
If Err.Number = 0 Then
' A. C'est un dossier -> On ajoute à la PILE pour le scanner plus tard
Pile.Add CheminComplet & "\"
' B. Si c'est celui qu'on cherche -> On ajoute au DICTIONARY
If Element = NomRecherche Then
' Dictionary gère les doublons tout seul (Clé unique)
' Ici la clé est le chemin complet
Dict(CheminComplet) = 1
End If
End If
End If
On Error GoTo 0
End If
' Element suivant
Element = Dir()
Loop
ContinueLoop:
Loop
' 3. TRANSFERT IMMEDIAT EN TABLEAU
' La propriété .Keys renvoie un tableau Variant() en une seule fois
' Pas de boucle de conversion nécessaire !
If Dict.Count > 0 Then
Chercheur_Dir_Dictionary = Dict.Keys
End If
End Function
