Utilisation récursive de dir (tous sous-dossiers et fichiers d'un volume ou répertoire)

**unparia** · 19/01/2017, 21h22

Bonjour
Ce dépôt fait suite à une très longue discussion relative à l'utilisation de la fonction Dir pour recenser de manière récursive les fichiers d'un volume, ou d'un répertoire ou d'un dossier spécifié.
Il montre comment faire ce recensement, qui peut être paramétré :
- choix des attributs de fichiers
- filtre sur les noms de dossiers/sous-dossiers
- filtre sur les noms de fichiers

Etant totalement opposé moi-même à l'ouverture de classeurs tiers, je n'en impose donc pas un aux autres et y substitue le dépôt du seul code

Pour le tester :
Sur une feuille :
- Un bouton de commande Commandbutton1
- un Label Label1 avec propriété visible = false

=============================================
- code dans le module de code de la feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
Option Explicit
 
Private Sub CommandButton1_Click()
 
  Dim attributs As Integer, dos As String, c As Range, toto As String, flt_fic As String, flt_dos As String
 
  dos = "d:\monoutil\" ' --->>> ici le nom de repertoire ou de volume à traiter
   flt_dos = "*ort*:*ulti*" ' --->>> ici le(s) filtres sur nom de dossier à chercher parmi d'autres dossiers
 
   flt_fic = "*" 'ou  le(s) filtre(s) de fichiers souhaités éventuelement ( ex : *.txt" ou *.txt:*png pour 2 filtres, etc ...)
 
  Application.EnableEvents = False ' IMPORTANT car on ne veut surtout pas que puisse se déclencher maintenant
                                   ' l'évènement selection_change. Ce commentaire est surtout destiné à ceux
                                   ' (j'en connais au moins un) qui "tripotaillent" puis déclarent que cela "ne marche pas"
  Application.ScreenUpdating = True
 
  ActiveSheet.Label1.Visible = False
 
  With Cells '-------------------------------------------- Rien de particulier à expliquer-là et qui pourrait
   .ClearContents ' on efface tout pour repartir "à neuf" |vous échapper.
   .Font.Name = "Tahoma" '                                |Je vide la feuille
   .Font.Size = 9 '                                       |Je choisis la police et la hauteur des lignes qui
   .RowHeight = 11 '                                      |correspondent à mes goûts. Si vous en avez d'autres,
 End With ' ---------------------------------------------- modifiez-les à votre guise.
DoEvents
 
 Dim deb As Double '| A effacer ensuite (n'est là que pour chronométrer
 deb = Timer '      |
 
 
'=====================================================================================
 'la ligne qui suit définit les attributs à retenir pour notre recensements           |
 ' elle est d'une très grande importance. l'attribut vbdirectory doit toujours être là|                                          |
 attributs = vbDirectory Or vbHidden Or vbNormal Or vbSystem Or vbReadOnly Or vbVolume ' TOUT       |
' attributs = vbDirectory Or vbHidden Or vbNormal ' tout sauf dossiers et/ou fichiers systeme     |
 'attributs = vbDirectory Or vbSystem Or vbReadOnly ' tout sauf cachés
 'attributs = vbDirectory Or vbHidden Or vbNormal Or vbReadOnly
 'attributs = vbDirectory Or vbNormal 'Or vbReadOnly
 '====================================================================================
 
 
 'dos = "d:\monoutil\"
 
 '============================================
 on_lance dos, attributs, flt_fic, flt_dos '  |-->> appel de l'outil
 '============================================
 
 Application.ScreenUpdating = True
 
 '======================================================================================================
 '=========================================================================================================
  'A ce niveau, le boulot fait par utilisation de la fonction Dir est totalement terminé et affiché.
  'Tout ce qui suit est autre chose et ne concerne que le choix de présentation des données extraites
  'et N'EST LA QU'A TITRE D'EXEMPLES (à suivre ou non, à compléter ou non, à votre gré)
  '=========================================================================================================
  '=========================================================================================================
 '====================================================================================================
 
 Dim question As Integer
 question = MsgBox("recensement fait, mis en matrice et affiché sur feuille de calcul en " & Timer - deb & " secondes pour " & vbCrLf & _
 Columns("A").SpecialCells(xlConstants).Count & " fichiers recensés " & "voulez-vous l'éclater (rapide) sur plusieurs colonnes ?", vbYesNo)
 Application.EnableEvents = True
 If question = vbYes Then
  deb = Timer '| A effacer ensuite (n'est là que pour chronométrer
  Application.ScreenUpdating = True
  Dim i As Long, k As Long, derlig As Long, dercol As Long, tablo()
  Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
  :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
  TrailingMinusNumbers:=True
  ActiveSheet.UsedRange '| mise à jour du usedrange
  tablo = UsedRange '    | et passation de ses données à une matrice
 
  On Error Resume Next ' cette gestion pour le cas où aucune occurrence de xlCellTypeFormulas
    'en "éclatant" nos chemins par colonnes, les cellules vont contenir des données dont chacune
    'contient un seul élément (nom de dossier ou nom de sous-dossier ou nom de fichier) du chemin
    'Or, certains d'entre eux peuvent commencer par un caractère tel (+,-,=, par exemple) que Excel pensera
    ' qu'il s'agit d'une formule et l'interprètera comme telle ! Avec pour conséquence, par exemple,
    ' la transformation de la donnée en "#NOM"
    ' or, telle que construite, notre feuille n'est censée contenir AUCUNE formule.
    'Il nous faut donc recenser ce qui a pu être ainsi transformé en formules et le retransformer en texte,
    'ce que fait ce qui suit. Mais il nous faut également prévoir qu'aucune cellule ne s'est vu attribuer de
    'formule malencontreusement. D'où la necessité de cette gestion d'erreur (en cas d'absence de "formule")
    For Each c In UsedRange.SpecialCells(xlCellTypeFormulas).Cells '--
      toto = c.Formula '                                              | Nous "dégradons" toute formule en
      Mid(toto, 1, 1) = "'" '                                         | remplaçant son 1er caractère par un '
      c.Formula = toto '                                              | ce qui aura pour effet d'obtenir du texte
    Next ' -----------------------------------------------------------
   On Error GoTo 0
 
  question = MsgBox("éclatement fait sur plusieurs colonnes en " & Timer - deb & " secondes" & vbCrLf & _
  "souhaitez-vous donner une apparence d'arborescence à l'affichage ?", vbYesNo)
   tablo = UsedRange  '    | passation des données des cellules à une matrice
  If question = vbYes Then
    derlig = Cells.SpecialCells(xlCellTypeLastCell).Row '----------
    dercol = Cells.SpecialCells(xlCellTypeLastCell).Column '       |Je vais vous faire grâce d'explications inutiles
    For k = 1 To UBound(tablo, 2) '                                |sur les instructions très élémentaires de
      For i = UBound(tablo, 1) To 2 Step -1 '                      |ce mécanisme qui, pour ligne de chaque colonne
        If tablo(i, k) <> "" Then '                                |n'efface que les chemins des dossiers déjà
          If tablo(i, k) = tablo(i - 1, k) Then tablo(i, k) = "" ' |extraits au-dessus
        End If '                                                   |
      Next '                                                       |
    Next '---------------------------------------------------------
    Range(Cells(1, 1), Cells(derlig, dercol)).Value = tablo ' et on affecte alors à la feuille les valeurs nouvelles de tablo
    MsgBox "affichage en apparence d'arbre terminée en " & Timer - deb & " secondes)"
  End If
 End If
End Sub
 
 
 
Private Sub Label1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  ' ceci uniquement pour ceux (les curieux) qui souhaiteraient en savoir plus sur ce fichier
  ' j'ouvre alors simplement l'explorateur à la sélection faite
  ' en le quittant, ils reviendront au point de départ
  On Error Resume Next ' --->> gestion d'erreur si vous nêtes pas autoriser à ouvrir l'explorateur
   Shell "explorer /select," & Label1.Caption, vbMaximizedFocus
  ' attention : ce geste fera découvrir l'existence réelle de fichiers recensés par Dir,
  ' mais que Windows ne voudra pas (il a SES raisons) qu'ils soient vraiment connus (vous aurez quelques
  ' petites surprises) ou qui sont des "images ISO" que vous avez créées là.
  ' un petit "coucou" à ce propos à quelqu'un qui devrait se reconnaître au passage (n'est-pas, l'ami ?)
  If Err Then MsgBox "vous n'êtes pas autorisé à ouvrir l'explorateur<. Voyez cela avec le responsable informatique"
  On Error GoTo 0
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
  ' Je  vais vous faire grâce d'explications trop détaillées sur les instructions qui suivent.
  ' Elles sont à la portée de tout développeur et n'ont pas grand-chose à voir avec l'utilisation
  ' de la fonction Dir (l'objet réel de cet outil)
  ' Elles ne sont qu'une série de "remontées" classiques, de colonne en colonne, coomppagnées d'une simple
  ' concaténation des données trouvées lors de chaque chaque "remontée ainsi conduite
  If Range("A1").Text = "" Or Target.Cells.Count > 1 Then Exit Sub ' ne pas afficher le label dans ces cas et permettre une sélection éventuelle
  Dim h As Long, toto As String, titi As String, lal As Long
  On Error Resume Next ' pourquoi cette gestion ? car après vidage et avant traitement, on va déclencher
                        ' cet évènement selection_change dans du "vide" -->> et donc générer une erreur !
                        ' je n'ai laissé ici cette gestion que pour faire face au cas où un "mal réveillé" aurait
                        ' cru inutile et effacé ma toute première ligne de l'évènement CommandButton1_Click
                        ' (voir à ce sujet le commentaire que j'y ai mis et un salut à ceux qui s'y reconnaîtraient...)
  If Target.Text = "" Then '|
    Label1.Visible = False '| oter de la vue le label alors inutile, voire encombrant
    Exit Sub '              |
  End If '                  |
  toto = ""
  For h = Target.Column To 1 Step -1 '---------------------------------------------
    If Target.Offset(0, -h + 1).Text <> "" Then '                                  |
      titi = Target.Offset(0, -h + 1).Text '                                       |Je remonte, de colonne en colonne,
    Else '                                                                         |chercher le dernier "noeud" connu
      lal = Target.Offset(0, -h + 1).End(xlUp).Row '                               |dans la colonne et concatène mes
      titi = Cells(lal, Target.Offset(0, -h + 1).Column).Value '                   |résultats
      If Err Then MsgBox Err.Number & "  " & Err.Description & "  " & Target.Text '|                                 |
    End If '                                                                       |
    toto = toto & "\" & titi '                                                     |
  Next '---------------------------------------------------------------------------
  On Error GoTo 0
 
  ' Il nous reste plus qu'à positionner notre label dont le caption est celui de la concaténation
  ' obtenue par nos "remontées". C'est tout.
 
  With Label1
    .Visible = True
    .Left = 0
    .Top = Target.Top - 1.1
    .Caption = Mid(toto, 2)
    .TextAlign = fmTextAlignCenter
    .Font.Name = Target.Font.Name
    .Font.Size = Target.Font.Size + 1
    .Height = Target.Height + 4.3
    .ForeColor = vbRed
    .Width = Target.Offset(0, 5).Left
  End With
End Sub

=======================================================================
Code dans un module standard :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
Option Explicit
Public Sub on_lance(DS As String, A As Integer, F_F As String, F_D As String)
  Dim L_D As Boolean, T_F_F, T_F_D, i As Long, k As Long, derlig As Long, dercol As Long, T_C As New Collection, lt
  ActiveSheet.Label1.Visible = False
  If F_F = "" Then F_F = "*"
  If F_D = "" Then F_D = "*": L_D = True
  T_F_F = Split(UCase(F_F), ":")
  If F_D <> "*" Then T_F_D = Split(UCase(F_D), ":")
  'Dim i As Long, k As Long, derlig As Long, dercol As Long, T_C As New Collection, lt
 
  For i = 1 To T_C.Count '--  on s'assure de vider la collection tremplin T_C
    T_C.Remove (1) '        | une interruption inopinée pourrait y avoir
  Next '--------------------  laissé traîner des éléments
 
  ReDim lt(0) ' on s'assure de vider la matrice lt
 
  T_C.Add DS ' on ajoute ici à notre collection T_C le chemin du dossier à traiter
  ' le bloc qui suit ne sera exécuté que lorsque la collection tremplin commencera à être remplie
  ' par l'appel de la procédure on_traite (puisque l'on examine sans cesse son état)
 
  '==========================================================================================
  Do While T_C.Count > 0 '==================================================================
    For i = T_C.Count To 1 Step -1 '                                                        # voilà ce que je baptise
      on_traite T_C(i), A, lt, T_C, T_F_F, T_F_D, L_D   'cet appel aura DEUX effets :        # "traitement en poupées gigognes"
                                                       'traitement d 'un élément de T_C     # Son mécanisme pourra paraître
                                                       'dans la foulée, abondement de       # complexe. Il n'en est rien.
                                                       ' T_C (et ainsi de suite)            #                            |
      T_C.Remove (i)  ' chaque fois qu'un élément de T_C a ainsi été traité, on le supprime # Prenez le temps de l'analyser.
    Next '                                                                                  #
  Loop '====================================================================================
   '==========================================================================================
 
 
  On Error Resume Next ' cette gestion est indispensable car la méthode transpose a une limite de colonnes à traiter
   Range("A1:A" & UBound(lt, 1)).Value = WorksheetFunction.Transpose(lt) ' on profite de transpose SI possible
 
   If Err Then ' uniquement si Transpose a échoué, donc -->>
    ReDim lt1(0 To UBound(lt) + 1, 1 To 2) '---  nous faisons alors nous-mêmes le boulot
    For i = 0 To UBound(lt) + 1 '              | que transpose n'a pu faire
     lt1(i, 1) = lt(i) '                       | nous alimentons un tableau de deux colonnes
    Next '                                     | dont il nous suffit maintenant de passer
    Range("A1:A" & UBound(lt)).Value = lt1 '---  tout simplement les valeurs à la colonne A
   End If
 
End Sub
Public Sub on_traite(DS As String, A As Integer, lt, T_C As Collection, T_F_F, T_F_D, L_D As Boolean)
  Dim N_E As String, CH As String, FDS As String, bon As Boolean, i As Integer
  If Right(DS, 1) <> "\" Then DS = DS & "\"
  FDS = Split(DS, "\")(UBound(Split(DS, "\")) - 1)
  On Error Resume Next ' cette gestion est IMPORTANTE (voir commentaires *** à la ligne suivante)
   N_E = Dir$(DS, A) '***** dir pourrait se "planter" sur des dossiers innaccesibles
 
   'Ce qui suit n'est jamais que l'utilisation la plus classique de la fonction Dir appliquée à un dossier
   ' je n'y commente donc que ce que nous faisons des résultats du parcours de ce seul dossier ou sous-dossier
   Do While N_E <> ""
     If N_E <> "." And N_E <> ".." Then
       CH = DS & N_E
       'On Error Resume Next ' hé oui ! cas d'innaccessibilité éventuelle (dossier alors recensé, mais pas son contenu)
 
       '============================= S'IL S'AGIT D'UN SOUS - DOSSIER ==========================================
        If GetAttr(CH) And vbDirectory Then '***** getattr pourrait se planter sur certains dossiers, voire fichiers spécifiques
         T_C.Add DS & N_E ' ->> on ajoute une poupée gigogne à T_C
 
         'Regardez bien le deux lignes de codes sui suivent et que j'ai mises en commentaires :
         'selon qu'on les commente ou qu'on les décommente, les sous-dossiers apparaîtront de
         'manière séparée ou n'apparaîtront qu'accompagnés du 1er fichier trouvé
         'j'estime personnellement que leur affichage "séparé" n'apporte rien et occupe de la place, mais
         'vous pouvez en juger autrement (il vous suffira alors de décommenter ces deux lignes)
 
                         'lt(UBound(lt)) = CH   '  on alimente notre matrice générale
                         'ReDim Preserve lt(UBound(lt) + 1) ' et on la redimensionne pour y mettre l'élément suivant
 
       '============================= S'IL S'AGIT D'UN FICHIER ==========================================
        Else
           bon = True
           If Not L_D Then ' inutile de contrôler si pas de filtre/dossier
              bon = False
              For i = 0 To UBound(T_F_D)
                If UCase(FDS) Like UCase(T_F_D(i)) Then bon = True: Exit For
              Next
            End If
            If bon = True Then ' on ne contrôle par rapport au filtre/fichier que si on est encore à true
              For i = 0 To UBound(T_F_F)
                If UCase(N_E) Like UCase(T_F_F(i)) Then
                   lt(UBound(lt)) = CH '  on alimente notre matrice générale
                   ReDim Preserve lt(UBound(lt) + 1) ' et on la redimensionne pour y mettre l'élément suivant
                   Exit For
                End If
              Next
            End If
        End If
     End If
     N_E = Dir
   Loop
End Sub

===========================================================
Parlons des filtres :
Ils se construisent très exactement comme se construisent les filtres de l'opérateur Like, avec utilisation éventuelle des mêmes caractères génériques.
Unique différence : si l'on décide de deux ou plusieurs filtres acceptés, ils doivent être séparés par le signe ":"
Quelques exemples :
flt_dos = "*ort*:*ulti*" ne retiendra que les dossiers dont le nom contient "ort" ou "ulti" contenant "ort" ou "ulti"
flt_dos = "ort*:*ulti*" ne retiendra que les dossiers dont le nom commence par "ort" ou contenant "ulti"
flt_dos = "ort" ne retiendrait que les dossiers dont le nom est "ort"
et bien évidemment : flt_dos = "*" retiendrait la totalité des dossiers
Le même principe s'applique en ce qui concerne les filtres de fichiers (flt_fic)
===========================================================
Parlons de l'utilisation de la variable attributs
Elle est commentée de manière assez claire dans le code. Elle permet de décider des seuls attributs de fichiers à retenir dans le recensement.
Notons à ce propos que la présence de l'attribut VBDirectory est indispensable dans tous les cas.
=========================================================
Vous noterez que des questions sont posées en ce qui concerne votre souhait de forme d'affichage des résultats. Il s'agit là d'une démo. Il va de soi que rien n'oblige à ces choix, que le développeur peut imposer comme il l'entend, s'il souhaite imposer un affichage
=========================================================
Quel que soit le choix fait d'affichage :
-- un clic sur une cellule d'article recensé affiche en rouge un label contenant le chemin complet de l'élément cliqué
-- un clic sur une cellule vide fait disparaître le label
-- un double-clic sur ce label conduit à ouvrir l'explorateur directement sur le fichier cliqué. La fermeture de l'explorateur fait revenir au Label.

===========================

UN DERNIER MOT : j'ai testé cette démo sur mon PC et sur plusieurs autres (de mes voisins) et ai fait l'observation suivante :
-- Sur mon PC ("vieille casserole" mais parfaitement "propre" et maintenue par mes soins, tant en ce qui concerne les défragmentations régulières que l'organisation du fichier de pagination), cette démo s'exécute dès le premier lancement en moins de 5 secondes, y compris pour recenser c:\
-- sur les PC de mes voisins (pourtant des machines bien plus modernes et performantes) le premier lancement est beaucoup plus lent (près de 2 minutes). Les lancements suivants sont par contre aussi rapides que sur ma machine.

======

Je me suis appliqué à commenter autant que faire se pouvait chaque partie du code que j'utilise et pense que la lecture de ces seuls commentaires éclairera suffisamment sur le déroulement du code

=====

Voilà. J'espère n'avoir rien oublié d'important à dire. Si tel n'était pas le cas, n'hésitez pas à me poser des questions. J'y répondrai.
--

**eriiic** · 20/01/2017, 01h44

Bonjour,

tout d'abord merci unparia.
Un premier test rapide sur des dossiers 'bateaux' n'a pas remonté de problème majeur. Juste quelques ajustements cosmétiques à mes préférences.
3 fichiers absents mais pas trop le temps actuellement de les rechercher (sur 4487, 412 dossiers). Sans doute un cas particulier.
Par contre aucune perte sur celui qui m'intéresse le plus (photos)
Question rapidité ça va ;-)
Dès que j'ai plus de temps dispo au retour de province je testerai et découvrirai plus en détail.
Super, ça servira pour un truc que j'ai en vue :-)
eric

**unparia** · 20/01/2017, 07h53

Bonjour eriiic et merci de ton retour
Je ne me suis pas intéressé du tout au côté "cosmétique". Ce code n'est là que pour montrer le "moteur", tout le reste (y compris la manière d'utiliser ce moteur, de n'en garder que la moelle, etc ...) est l'affaire de chacun.
Je n'ai pas voulu non plus (toujours avec la volonté de ne pas brouiller des pistes) paramétrer plus ce moteur et en faire une fonction totalement séparée mais moins facile à décortiquer, ni l'accompagner de boîtes de dialogues éventuelles, etc ... . A chacun de le faire comme il l'entend également (c'est extrêmement simple à faire). Seul le moteur doit ici retenir l'attention.

Les 3 éléments non recensés sont en effet probablement des fichiers/dossiers spéciaux ou non accessibles, en général présents à la racine d'un volume. Si tu veux les connaître (mais en aucun cas les recenser) , tu peux le faire assez facilement en ajoutant quelques lignes de code en lignes 63 et 52 du code de la procédure "on_traite".

**anasecu** · 20/01/2017, 08h56

Bonjour unparia,

Envoyé par unparia

Seul le moteur doit ici retenir l'attention.

J'étais aussi alléché par la discussion que j'avais suivie mais pour moi le moteur cale sur la "question" j'ai une erreur 1004 "pas de cellule correspondante" : normal ma feuille est vide.

**pijaku** · 20/01/2017, 09h13

Bonjour,

Je viens d'essayer ton code, Jacques.

Comme ma machine est mal entretenue, je remarque les mêmes lenteurs que chez tes voisins.
Par contre, à chaque fois, pas uniquement au premier lancement.
Pas grave.

Tout comme Eriiic (salutations), je note une "perte" de 4-5 fichiers. Tu nous en as donné l'explication, pas de souci.

Pour ton information :

Ton code recense 181 215 fichiers en 4 minutes 25 secondes,
L'éclatement par colonnes de ces 181 000 fichiers se fait en 8 secondes,
l'affichage en arborescence, quant à lui, dure 33 secondes.

Le tout sur ma machine "moyenne" et pas entretenue...

EDIT : @ anasecu,
As tu adapté, à ta situation, les lignes 7 et 8 du code du module de la feuille??

**anasecu** · 20/01/2017, 10h13

Bonjour à tous,

Envoyé par pijaku

@ anasecu, As tu adapté, à ta situation, les lignes 7 et 8 du code du module de la feuille??

Bien sûr, cela fonctionne beaucoup mieux car "monoutil" est vide chez moi !

Au temps pour moi, il eu fallut éviter la lecture rapide !

@unparia
une erreur sur ce test 'Target.Cells.Count' car avec les excels après 2003 il faut tester Target.Cells.CountLarge

Cependant je trouve dommage que le paramètre soit dans le code car cela va être réservé à une petite catégorie d'utilisateurs

**unparia** · 20/01/2017, 10h18

Envoyé par anasecu

Cependant je trouve dommage que le paramètre soit dans le code car cela va être réservé à une petite catégorie d'utilisateurs

Ce n'est pas un outil, qui est déposé là, mais le mécanisme d'un moteur, à l'attention de développeurs (tous ceux qui sont ici sont censés être des développeurs)..
A chacun d'insérer ce mécanisme dans l'outil qu'il souhaite faire.

**unparia** · 20/01/2017, 10h22

Envoyé par pijaku

Par contre, à chaque fois, pas uniquement au premier lancement.

Deux causes possibles :
1) Indexation des dossiers non choisie. Utilise cette l'indexation (explorateur)
2) Fichier de pagination mal géré.

**Philippe Tulliez** · 20/01/2017, 12h34

Bonjour Unparia,
J'avoue assez sidérant comme vitesse

Sur ma machine Linux le programme lancé au départ de Windows (VirtualBox) recense 25.761 fichiers en 28 secondes.

**pijaku** · 20/01/2017, 12h52

Envoyé par unparia

Deux causes possibles :
1) Indexation des dossiers non choisie. Utilise cette l'indexation (explorateur)

Tout à fait exact !
Ton code trouve maintenant plus de fichiers en 30 secondes.
Bien vu, et merci.

**eriiic** · 23/01/2017, 00h21

Bonjour à tous,

J'ai démarré mon outil de sauvegarde de l'horodatage des fichiers.
Je vois que j'ai un répertoire de 3800 fichiers dont je n'ai que faire en fait (previews de photos).
Un filtre des dossiers et un des fichiers à exclure peut donc être utile, pour éliminer aussi les fichiers ~$* et autres *.tmp .
Je vais l'ajouter mais au passage je te soumet l'idée unparia, des fois que tu aies l'envie de compléter le moteur avec cette option.

Sur mon PC de 10 ans d'age (CM et proc d'origine encore, hé oui ! :-) ) : 1.4 s pour 9800 fichiers, que je double avec la récup des dates et tailles. Plus que raisonnable :-)
Encore merci
eric

**unparia** · 23/01/2017, 07h44

Bonjour eriic
Je n'ai pas voulu compliquer et "noyer" un peu l'essentiel.
Ceux qui le désirent peuvent éviter deux filtres du type flt_fic (un pour les "bons" et l'autre pour ceux à ignorer)
Il suffit pour cela d'utiliser, dans le filtre flt_fic un second "séparateur" ayant valeur de "AND" et ne risquant pas d'être présent dans un nom de fichier. Ce second séparateur peut donc par exemple être le "\"
A partir de là : construire un second "T_F_F" (disons "T_F_F1) contenant les critères "AND" (des AND NOT, en fait)
Et dans la vérification : ne regarder les OR que si aucun AND NOT présent
Si tu veux le faire : les critères "AND NOT" dans flt_fic devront revêtir la forme (exemple pour refuser les *.txt) ---> *.[!t][!x][!t] (voir les règles applicables à Like) ***************

************** = de sorte à n'utiliser toujours que Like et non un coup Like et l'autre Not Like.
Amitiés

**eriiic** · 23/01/2017, 12h51

Bonjour unparia,

c'est vrai que mon idée première était d'ajouter 2 listes de filtre, je n'avais pas pensé à *.[!t][!x][!t] (si tant est que ça ait imprégné ma mémoire un jour

).
Seulement mes premiers tests font que If UCase(FDS) Like UCase(T_F_D(i)) Then est toujours faux et je ne sors plus rien.
Sans doute que je m'y prend mal et quelque chose doit m'échapper. Là je prépare un départ pour demain, je reprendrai à mon retour.
Mais bon, on s'écarte du coeur du topic. Ce n'est pas insoluble ni le plus dur, j'y arriverai avec un peu plus de temps :-)
Merci du retour et de l'idée.
eric

**unparia** · 23/01/2017, 18h20

Bon.
Je veux bien (dès que j'aurais un moment) développer avec ce rajout, mais :
1) il ralentira forcément l'ensemble (puisque conditions supplémentaires)
2) ce code ne devra pas "troubler" la moelle (le tout premier code, tel qu'il est) et contribuer à perdre celui qui analyse le moteur
3) il va alors falloir donner encore d'autres explications quant au mode d'emploi (en espérant qu'elles soient parfaitement claires, comprises et appliquées).
Je ne substituerai donc pas ce code à celui du moteur déjà montré, mais le montrerai dans le cours de la présente discussion.

**eriiic** · 24/01/2017, 00h02

Merci unparia, mais je pense revenir à ma 1ère idée : ajouter 2 autres listes + filtres and not like.
L'idée d'utiliser [!t] est bonne mais est un peu fastidieuse à la saisie (mis à part le fait que je n'y ai pas encore réussi, il faut que je m’imprègne un peu plus de ton code).
Par exemple mon répertoire à exclure serait *.[!l][!r][!d][!a][!t][!a]. Imagine s'il y en a plusieurs.
Au niveau de l'impact je pense que souvent l'un ou l'autre ou les deux seront vides, et il pourra se limiter à 2 tests de booléen en plus non ?
Repos maintenant, j'ai de la route demain... :-s
eric

**unparia** · 24/01/2017, 08h10

Tu as peut-être raison (moins difficile, du coup) :
alors voilà les transformations à apporter si l'on veut pouvoir en plus ajouter des filtres de fichiers à ignorer :
Module de code de la feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
Option Explicit
 
Private Sub CommandButton1_Click()
 
  Dim attributs As Integer, dos As String, c As Range, toto As String, flt_fic As String, flt_dos As String, flt_fic_ignorer As String
 
  dos = "d:\monoutil\" ' --->>> ici le nom de repertoire ou de volume à traiter
   flt_dos = "*ort*:*ulti*" ' --->>> ici le(s) filtres sur nom de dossier à chercher parmi d'autres dossiers
 
   flt_fic = "*" 'ou  le(s) filtre(s) de fichiers souhaités éventuelement ( ex : *.txt" ou *.txt:*png pour 2 filtres, etc ...)
 
   flt_fic_ignorer = "*.frm:*.vbp:MS*" ' ici : soit "" (pour rien à ignorer, soit le(s) filtre(s) à ignorer
 
  Application.EnableEvents = False ' IMPORTANT car on ne veut surtout pas que puisse se déclencher maintenant
                                   ' l'évènement selection_change. Ce commentaire est surtout destiné à ceux
                                   ' (j'en connais au moins un) qui "tripotaillent" puis déclarent que cela "ne marche pas"
  Application.ScreenUpdating = True
 
  ActiveSheet.Label1.Visible = False
 
  With Cells '-------------------------------------------- Rien de particulier à expliquer-là et qui pourrait
   .ClearContents ' on efface tout pour repartir "à neuf" |vous échapper.
   .Font.Name = "Tahoma" '                                |Je vide la feuille
   .Font.Size = 9 '                                       |Je choisis la police et la hauteur des lignes qui
   .RowHeight = 11 '                                      |correspondent à mes goûts. Si vous en avez d'autres,
 End With ' ---------------------------------------------- modifiez-les à votre guise.
DoEvents
 
 Dim deb As Double '| A effacer ensuite (n'est là que pour chronométrer
 deb = Timer '      |
 
 
'=====================================================================================
 'la ligne qui suit définit les attributs à retenir pour notre recensements           |
 ' elle est d'une très grande importance. l'attribut vbdirectory doit toujours être là|                                          |
 attributs = vbDirectory Or vbHidden Or vbNormal Or vbSystem Or vbReadOnly Or vbVolume ' TOUT       |
' attributs = vbDirectory Or vbHidden Or vbNormal ' tout sauf dossiers et/ou fichiers systeme     |
 'attributs = vbDirectory Or vbSystem Or vbReadOnly ' tout sauf cachés
 'attributs = vbDirectory Or vbHidden Or vbNormal Or vbReadOnly
 'attributs = vbDirectory Or vbNormal 'Or vbReadOnly
 '====================================================================================
 
 
 'dos = "d:\monoutil\"
 
 '============================================
 on_lance dos, attributs, flt_fic, flt_fic_ignorer, flt_dos '  |-->> appel de l'outil
 '============================================
 
 Application.ScreenUpdating = True
 
 '======================================================================================================
 '=========================================================================================================
  'A ce niveau, le boulot fait par utilisation de la fonction Dir est totalement terminé et affiché.
  'Tout ce qui suit est autre chose et ne concerne que le choix de présentation des données extraites
  'et N'EST LA QU'A TITRE D'EXEMPLES (à suivre ou non, à compléter ou non, à votre gré)
  '=========================================================================================================
  '=========================================================================================================
 '====================================================================================================
 
 Dim question As Integer
 question = MsgBox("recensement fait, mis en matrice et affiché sur feuille de calcul en " & Timer - deb & " secondes pour " & vbCrLf & _
 Columns("A").SpecialCells(xlConstants).Count & " fichiers recensés " & "voulez-vous l'éclater (rapide) sur plusieurs colonnes ?", vbYesNo)
 Application.EnableEvents = True
 If question = vbYes Then
  deb = Timer '| A effacer ensuite (n'est là que pour chronométrer
  Application.ScreenUpdating = True
  Dim i As Long, k As Long, derlig As Long, dercol As Long, tablo()
  Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
  :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
  TrailingMinusNumbers:=True
  ActiveSheet.UsedRange '| mise à jour du usedrange
  tablo = UsedRange '    | et passation de ses données à une matrice
 
  On Error Resume Next ' cette gestion pour le cas où aucune occurrence de xlCellTypeFormulas
    'en "éclatant" nos chemins par colonnes, les cellules vont contenir des données dont chacune
    'contient un seul élément (nom de dossier ou nom de sous-dossier ou nom de fichier) du chemin
    'Or, certains d'entre eux peuvent commencer par un caractère tel (+,-,=, par exemple) que Excel pensera
    ' qu'il s'agit d'une formule et l'interprètera comme telle ! Avec pour conséquence, par exemple,
    ' la transformation de la donnée en "#NOM"
    ' or, telle que construite, notre feuille n'est censée contenir AUCUNE formule.
    'Il nous faut donc recenser ce qui a pu être ainsi transformé en formules et le retransformer en texte,
    'ce que fait ce qui suit. Mais il nous faut également prévoir qu'aucune cellule ne s'est vu attribuer de
    'formule malencontreusement. D'où la necessité de cette gestion d'erreur (en cas d'absence de "formule")
    For Each c In UsedRange.SpecialCells(xlCellTypeFormulas).Cells '--
      toto = c.Formula '                                              | Nous "dégradons" toute formule en
      Mid(toto, 1, 1) = "'" '                                         | remplaçant son 1er caractère par un '
      c.Formula = toto '                                              | ce qui aura pour effet d'obtenir du texte
    Next ' -----------------------------------------------------------
   On Error GoTo 0
 
  question = MsgBox("éclatement fait sur plusieurs colonnes en " & Timer - deb & " secondes" & vbCrLf & _
  "souhaitez-vous donner une apparence d'arborescence à l'affichage ?", vbYesNo)
   tablo = UsedRange  '    | passation des données des cellules à une matrice
  If question = vbYes Then
    derlig = Cells.SpecialCells(xlCellTypeLastCell).Row '----------
    dercol = Cells.SpecialCells(xlCellTypeLastCell).Column '       |Je vais vous faire grâce d'explications inutiles
    For k = 1 To UBound(tablo, 2) '                                |sur les instructions très élémentaires de
      For i = UBound(tablo, 1) To 2 Step -1 '                      |ce mécanisme qui, pour ligne de chaque colonne
        If tablo(i, k) <> "" Then '                                |n'efface que les chemins des dossiers déjà
          If tablo(i, k) = tablo(i - 1, k) Then tablo(i, k) = "" ' |extraits au-dessus
        End If '                                                   |
      Next '                                                       |
    Next '---------------------------------------------------------
    Range(Cells(1, 1), Cells(derlig, dercol)).Value = tablo ' et on affecte alors à la feuille les valeurs nouvelles de tablo
    MsgBox "affichage en apparence d'arbre terminée en " & Timer - deb & " secondes)"
  End If
 End If
End Sub
 
 
 
Private Sub Label1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  ' ceci uniquement pour ceux (les curieux) qui souhaiteraient en savoir plus sur ce fichier
  ' j'ouvre alors simplement l'explorateur à la sélection faite
  ' en le quittant, ils reviendront au point de départ
  On Error Resume Next ' --->> gestion d'erreur si vous nêtes pas autoriser à ouvrir l'explorateur
   Shell "explorer /select," & Label1.Caption, vbMaximizedFocus
  ' attention : ce geste fera découvrir l'existence réelle de fichiers recensés par Dir,
  ' mais que Windows ne voudra pas (il a SES raisons) qu'ils soient vraiment connus (vous aurez quelques
  ' petites surprises) ou qui sont des "images ISO" que vous avez créées là.
  ' un petit "coucou" à ce propos à quelqu'un qui devrait se reconnaître au passage (n'est-pas, l'ami ?)
  If Err Then MsgBox "vous n'êtes pas autorisé à ouvrir l'explorateur<. Voyez cela avec le responsable informatique"
  On Error GoTo 0
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
  ' Je  vais vous faire grâce d'explications trop détaillées sur les instructions qui suivent.
  ' Elles sont à la portée de tout développeur et n'ont pas grand-chose à voir avec l'utilisation
  ' de la fonction Dir (l'objet réel de cet outil)
  ' Elles ne sont qu'une série de "remontées" classiques, de colonne en colonne, coomppagnées d'une simple
  ' concaténation des données trouvées lors de chaque chaque "remontée ainsi conduite
  If Range("A1").Text = "" Or Target.Cells.Count > 1 Then Exit Sub ' ne pas afficher le label dans ces cas et permettre une sélection éventuelle
  Dim h As Long, toto As String, titi As String, lal As Long
  On Error Resume Next ' pourquoi cette gestion ? car après vidage et avant traitement, on va déclencher
                        ' cet évènement selection_change dans du "vide" -->> et donc générer une erreur !
                        ' je n'ai laissé ici cette gestion que pour faire face au cas où un "mal réveillé" aurait
                        ' cru inutile et effacé ma toute première ligne de l'évènement CommandButton1_Click
                        ' (voir à ce sujet le commentaire que j'y ai mis et un salut à ceux qui s'y reconnaîtraient...)
  If Target.Text = "" Then '|
    Label1.Visible = False '| oter de la vue le label alors inutile, voire encombrant
    Exit Sub '              |
  End If '                  |
  toto = ""
  For h = Target.Column To 1 Step -1 '---------------------------------------------
    If Target.Offset(0, -h + 1).Text <> "" Then '                                  |
      titi = Target.Offset(0, -h + 1).Text '                                       |Je remonte, de colonne en colonne,
    Else '                                                                         |chercher le dernier "noeud" connu
      lal = Target.Offset(0, -h + 1).End(xlUp).Row '                               |dans la colonne et concatène mes
      titi = Cells(lal, Target.Offset(0, -h + 1).Column).Value '                   |résultats
      If Err Then MsgBox Err.Number & "  " & Err.Description & "  " & Target.Text '|                                 |
    End If '                                                                       |
    toto = toto & "\" & titi '                                                     |
  Next '---------------------------------------------------------------------------
  On Error GoTo 0
 
  ' Il nous reste plus qu'à positionner notre label dont le caption est celui de la concaténation
  ' obtenue par nos "remontées". C'est tout.
 
  With Label1
    .Visible = True
    .Left = 0
    .Top = Target.Top - 1.1
    .Caption = Mid(toto, 2)
    .TextAlign = fmTextAlignCenter
    .Font.Name = Target.Font.Name
    .Font.Size = Target.Font.Size + 1
    .Height = Target.Height + 4.3
    .ForeColor = vbRed
    .Width = Target.Offset(0, 5).Left
  End With
End Sub

Et dans le module standard :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
Option Explicit
Public Sub on_lance(DS As String, A As Integer, F_F As String, F_FI As String, F_D As String)
  Dim L_D As Boolean, T_F_F, T_F_FI, T_F_D, i As Long, k As Long, derlig As Long, dercol As Long, T_C As New Collection, lt, CT_I As Boolean
  ActiveSheet.Label1.Visible = False
  If F_F = "" Then F_F = "*"
  If F_D = "" Then F_D = "*": L_D = True
  T_F_F = Split(UCase(F_F), ":")
  If F_FI <> "" Then
    T_F_FI = Split(UCase(F_FI), ":")
    CT_I = True
  Else
    CT_I = False
  End If
 
  If F_D <> "*" Then T_F_D = Split(UCase(F_D), ":")
  'Dim i As Long, k As Long, derlig As Long, dercol As Long, T_C As New Collection, lt
 
  For i = 1 To T_C.Count '--  on s'assure de vider la collection tremplin T_C
    T_C.Remove (1) '        | une interruption inopinée pourrait y avoir
  Next '--------------------  laissé traîner des éléments
 
  ReDim lt(0) ' on s'assure de vider la matrice lt
 
  T_C.Add DS ' on ajoute ici à notre collection T_C le chemin du dossier à traiter
  ' le bloc qui suit ne sera exécuté que lorsque la collection tremplin commencera à être remplie
  ' par l'appel de la procédure on_traite (puisque l'on examine sans cesse son état)
 
  '==========================================================================================
  Do While T_C.Count > 0 '==================================================================
    For i = T_C.Count To 1 Step -1 '                                                        # voilà ce que je baptise
      on_traite T_C(i), A, lt, T_C, T_F_F, T_F_FI, T_F_D, L_D, CT_I  'cet appel aura DEUX effets :        # "traitement en poupées gigognes"
                                                       'traitement d 'un élément de T_C     # Son mécanisme pourra paraître
                                                       'dans la foulée, abondement de       # complexe. Il n'en est rien.
                                                       ' T_C (et ainsi de suite)            #                            |
      T_C.Remove (i)  ' chaque fois qu'un élément de T_C a ainsi été traité, on le supprime # Prenez le temps de l'analyser.
    Next '                                                                                  #
  Loop '====================================================================================
   '==========================================================================================
 
 
  On Error Resume Next ' cette gestion est indispensable car la méthode transpose a une limite de colonnes à traiter
   Range("A1:A" & UBound(lt, 1)).Value = WorksheetFunction.Transpose(lt) ' on profite de transpose SI possible
 
   If Err Then ' uniquement si Transpose a échoué, donc -->>
    ReDim lt1(0 To UBound(lt) + 1, 1 To 2) '---  nous faisons alors nous-mêmes le boulot
    For i = 0 To UBound(lt) + 1 '              | que transpose n'a pu faire
     lt1(i, 1) = lt(i) '                       | nous alimentons un tableau de deux colonnes
    Next '                                     | dont il nous suffit maintenant de passer
    Range("A1:A" & UBound(lt)).Value = lt1 '---  tout simplement les valeurs à la colonne A
   End If
 
End Sub
Public Sub on_traite(DS As String, A As Integer, lt, T_C As Collection, T_F_F, T_F_FI, T_F_D, L_D As Boolean, CT_I As Boolean)
  Dim N_E As String, CH As String, FDS As String, bon As Boolean, i As Integer
  If Right(DS, 1) <> "\" Then DS = DS & "\"
  FDS = Split(DS, "\")(UBound(Split(DS, "\")) - 1)
  On Error Resume Next ' cette gestion est IMPORTANTE (voir commentaires *** à la ligne suivante)
   N_E = Dir$(DS, A) '***** dir pourrait se "planter" sur des dossiers innaccesibles
 
   'Ce qui suit n'est jamais que l'utilisation la plus classique de la fonction Dir appliquée à un dossier
   ' je n'y commente donc que ce que nous faisons des résultats du parcours de ce seul dossier ou sous-dossier
   Do While N_E <> ""
     If N_E <> "." And N_E <> ".." Then
       CH = DS & N_E
       'On Error Resume Next ' hé oui ! cas d'innaccessibilité éventuelle (dossier alors recensé, mais pas son contenu)
 
       '============================= S'IL S'AGIT D'UN SOUS - DOSSIER ==========================================
        If GetAttr(CH) And vbDirectory Then '***** getattr pourrait se planter sur certains dossiers, voire fichiers spécifiques
         T_C.Add DS & N_E ' ->> on ajoute une poupée gigogne à T_C
 
         'Regardez bien le deux lignes de codes sui suivent et que j'ai mises en commentaires :
         'selon qu'on les commente ou qu'on les décommente, les sous-dossiers apparaîtront de
         'manière séparée ou n'apparaîtront qu'accompagnés du 1er fichier trouvé
         'j'estime personnellement que leur affichage "séparé" n'apporte rien et occupe de la place, mais
         'vous pouvez en juger autrement (il vous suffira alors de décommenter ces deux lignes)
 
                         'lt(UBound(lt)) = CH   '  on alimente notre matrice générale
                         'ReDim Preserve lt(UBound(lt) + 1) ' et on la redimensionne pour y mettre l'élément suivant
 
       '============================= S'IL S'AGIT D'UN FICHIER ==========================================
        Else
           bon = True
           If Not L_D Then ' inutile de contrôler si pas de filtre/dossier
              bon = False
              For i = 0 To UBound(T_F_D)
                If UCase(FDS) Like UCase(T_F_D(i)) Then bon = True: Exit For
              Next
            End If
            If bon = True Then ' on ne contrôle par rapport au filtre/fichier que si on est encore à true
              If CT_I Then
                For i = 0 To UBound(T_F_FI)
                  If UCase(N_E) Like UCase(T_F_FI(i)) Then
                     bon = False: Exit For
                  End If
                Next
              End If
              If bon = True Then
                For i = 0 To UBound(T_F_F)
                  If UCase(N_E) Like UCase(T_F_F(i)) Then
                     lt(UBound(lt)) = CH '  on alimente notre matrice générale
                     ReDim Preserve lt(UBound(lt) + 1) ' et on la redimensionne pour y mettre l'élément suivant
                     Exit For
                  End If
                Next
              End If
            End If
          End If
       End If
     N_E = Dir
   Loop
End Sub

Attention à l'initialisation de la variable flt_fic_ignorer :
Exemple :
"" = rien à ignorer
"*.frm:*.vbp:MS*" = tous les fichiers d'extension frm ET tous les fichiers dont l'extension est vbp ET tous les fichiers dont le nom commence par MS
(en espérant que personne n'ira mettre ici = "*" !!!!!!!

**eriiic** · 26/01/2017, 00h15

Bonjour unparia,

J'ai eu du temps à mon retour : testé et approuvé comme on s'en doutait :-)
J'ai ajouté sur le même principe l'exclusion de répertoires.
Une quinzaine de lignes en 3 blocs que j'ai encadrées de '****** 25/01/16 **** pour les repérer, plus l'ajout de variables.
Veux-tu que je te le transmette voir si ça te parait respecter le principe que tu as mis en place ou s'il y aurait eu plus direct ?

Une question qui me turlupine si tu veux bien.
Y-a-t-il une raison sur le choix de ":" comme séparateur des filtres. Un parmi ceux interdits ou une raison plus particulière ?
Merci :-)
eric

**unparia** · 26/01/2017, 06h47

Bonjour eriiic

Y-a-t-il une raison sur le choix de ":" comme séparateur des filtres. Un parmi ceux interdits ou une raison plus particulière ?

le ":" est tout simplement choisi parmi les caractères interdits dans un chemin de fichier. N'importe quel autre de ces caractères interdits, sauf bien évidemment le "*" et le "?" ferait l'affaire également. (le "*" et le "?" sont à proscrire pour éviter toute confusion possible avec les caractères génériques de l'opérateur Like).
Nous aurions pu choisir le caractère 1 ( chr(1) ) comme séparateur, puisqu'il ne risque pas de figurer dans un chemin. J'ai toutefois préféré ne pas l'utiliser pour ne pas compliquer la tâche de l'utilisateur

Pour ce qui est des filtres/dossiers à ignorer : pas la peine de me le transmettre (*****). Fais tes tests et si bons -->> mets tout simplement ici le code complété.

***** -->> je n'ai écrit et déposé ce code que pour montrer les performances de la fonction Dir, comparées à celles de FSO.
Il sera totalement supprimé de ma machine (comme toujours) dans 15 jours. J'utilise en effet quant à moi (ainsi que je l'ai exposé dans une discussion) un outil tout autre ("philosophie" incluse) que celui-ci. Il passe par la mise à jour d'une base de données sur laquelle j'effectue à la demande des requêtes très précises en fonction de ce que je veux savoir et/ou afficher.
Cette mise à jour se fait carrément hors Excel et son VBA. L'exploitation de cette base pouvant être bien évidemment faite ensuite depuis où ( application et langage) on le souhaite.

C'est donc tout autre chose.

Amitiés

**eriiic** · 26/01/2017, 18h13

Bonjour,

Donc le travail de unparia avec l'option 'Dossiers à exclure' ajoutée si quelqu'un a le même besoin que moi.
(mettre flt_dos_ignorer = "" si non utilisée)

Module de code de la feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
Option Explicit
 
Private Sub CommandButton1_Click()
 
  Dim attributs As Integer, dos As String, c As Range, toto As String, flt_fic As String, flt_dos As String, flt_fic_ignorer As String, flt_dos_ignorer As String
 
   dos = "D:\" ' --->>> ici le nom de repertoire ou de volume à traiter
   flt_dos = "*" ' "*ort*:*ulti*" --->>> ici le(s) filtres sur nom de dossier à chercher parmi d'autres dossiers
 
   '****** 25/01/16 ******
   flt_dos_ignorer = "$RECYCLE.BIN:Temporary Internet Files:Temp:tmp*:*.lrdata" ' "" ou "*ort*:*ulti*" --->>> ici le(s) filtres sur nom de dossier à exclure : soit "" (pour rien à ignorer, soit le(s) filtre(s) à ignorer
   '****** fin 25/01/16 ****
 
   flt_fic = "*" 'ou  le(s) filtre(s) de fichiers souhaités éventuelement ( ex : *.txt" ou *.txt:*png pour 2 filtres, etc ...)
 
   flt_fic_ignorer = "~$*:thumbs.db" ' "" ou "*.frm:*.vbp:MS*" ici : soit "" (pour rien à ignorer, soit le(s) filtre(s) à ignorer
 
  Application.EnableEvents = False ' IMPORTANT car on ne veut surtout pas que puisse se déclencher maintenant
                                   ' l'évènement selection_change. Ce commentaire est surtout destiné à ceux
                                   ' (j'en connais au moins un) qui "tripotaillent" puis déclarent que cela "ne marche pas"
  Application.ScreenUpdating = True
 
  ActiveSheet.Label1.Visible = False
 
  With Cells '-------------------------------------------- Rien de particulier à expliquer-là et qui pourrait
   .ClearContents ' on efface tout pour repartir "à neuf" |vous échapper.
   .Font.Name = "Tahoma" '                                |Je vide la feuille
   .Font.Size = 9 '                                       |Je choisis la police et la hauteur des lignes qui
   .RowHeight = 11 '                                      |correspondent à mes goûts. Si vous en avez d'autres,
 End With ' ---------------------------------------------- modifiez-les à votre guise.
DoEvents
 
 Dim deb As Double '| A effacer ensuite (n'est là que pour chronométrer
 deb = Timer '      |
 
 
'=====================================================================================
 'la ligne qui suit définit les attributs à retenir pour notre recensements           |
 ' elle est d'une très grande importance. l'attribut vbdirectory doit toujours être là|                                          |
 attributs = vbDirectory Or vbHidden Or vbNormal Or vbSystem Or vbReadOnly Or vbVolume ' TOUT       |
' attributs = vbDirectory Or vbHidden Or vbNormal ' tout sauf dossiers et/ou fichiers systeme     |
 'attributs = vbDirectory Or vbSystem Or vbReadOnly ' tout sauf cachés
 'attributs = vbDirectory Or vbHidden Or vbNormal Or vbReadOnly
 'attributs = vbDirectory Or vbNormal 'Or vbReadOnly
 '====================================================================================
 
 
 'dos = "d:\monoutil\"
 
 '============================================
 on_lance dos, attributs, flt_fic, flt_fic_ignorer, flt_dos, flt_dos_ignorer '  |-->> appel de l'outil
 '============================================
 
 Application.ScreenUpdating = True
 
 '======================================================================================================
 '=========================================================================================================
  'A ce niveau, le boulot fait par utilisation de la fonction Dir est totalement terminé et affiché.
  'Tout ce qui suit est autre chose et ne concerne que le choix de présentation des données extraites
  'et N'EST LA QU'A TITRE D'EXEMPLES (à suivre ou non, à compléter ou non, à votre gré)
  '=========================================================================================================
  '=========================================================================================================
 '====================================================================================================
 
 Dim question As Integer
 question = MsgBox("recensement fait, mis en matrice et affiché sur feuille de calcul en " & Timer - deb & " secondes pour " & vbCrLf & _
 Columns("A").SpecialCells(xlConstants).Count & " fichiers recensés " & "voulez-vous l'éclater (rapide) sur plusieurs colonnes ?", vbYesNo)
 Application.EnableEvents = True
 If question = vbYes Then
  deb = Timer '| A effacer ensuite (n'est là que pour chronométrer
  Application.ScreenUpdating = True
  Dim i As Long, k As Long, derlig As Long, dercol As Long, tablo()
  Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
  :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
  TrailingMinusNumbers:=True
  ActiveSheet.UsedRange '| mise à jour du usedrange
  tablo = UsedRange '    | et passation de ses données à une matrice
 
  On Error Resume Next ' cette gestion pour le cas où aucune occurrence de xlCellTypeFormulas
    'en "éclatant" nos chemins par colonnes, les cellules vont contenir des données dont chacune
    'contient un seul élément (nom de dossier ou nom de sous-dossier ou nom de fichier) du chemin
    'Or, certains d'entre eux peuvent commencer par un caractère tel (+,-,=, par exemple) que Excel pensera
    ' qu'il s'agit d'une formule et l'interprètera comme telle ! Avec pour conséquence, par exemple,
    ' la transformation de la donnée en "#NOM"
    ' or, telle que construite, notre feuille n'est censée contenir AUCUNE formule.
    'Il nous faut donc recenser ce qui a pu être ainsi transformé en formules et le retransformer en texte,
    'ce que fait ce qui suit. Mais il nous faut également prévoir qu'aucune cellule ne s'est vu attribuer de
    'formule malencontreusement. D'où la necessité de cette gestion d'erreur (en cas d'absence de "formule")
    For Each c In UsedRange.SpecialCells(xlCellTypeFormulas).Cells '--
      toto = c.Formula '                                              | Nous "dégradons" toute formule en
      Mid(toto, 1, 1) = "'" '                                         | remplaçant son 1er caractère par un '
      c.Formula = toto '                                              | ce qui aura pour effet d'obtenir du texte
    Next ' -----------------------------------------------------------
   On Error GoTo 0
 
  question = MsgBox("éclatement fait sur plusieurs colonnes en " & Timer - deb & " secondes" & vbCrLf & _
  "souhaitez-vous donner une apparence d'arborescence à l'affichage ?", vbYesNo)
   tablo = UsedRange  '    | passation des données des cellules à une matrice
  If question = vbYes Then
    derlig = Cells.SpecialCells(xlCellTypeLastCell).Row '----------
    dercol = Cells.SpecialCells(xlCellTypeLastCell).Column '       |Je vais vous faire grâce d'explications inutiles
    For k = 1 To UBound(tablo, 2) '                                |sur les instructions très élémentaires de
      For i = UBound(tablo, 1) To 2 Step -1 '                      |ce mécanisme qui, pour ligne de chaque colonne
        If tablo(i, k) <> "" Then '                                |n'efface que les chemins des dossiers déjà
          If tablo(i, k) = tablo(i - 1, k) Then tablo(i, k) = "" ' |extraits au-dessus
        End If '                                                   |
      Next '                                                       |
    Next '---------------------------------------------------------
    Range(Cells(1, 1), Cells(derlig, dercol)).Value = tablo ' et on affecte alors à la feuille les valeurs nouvelles de tablo
    MsgBox "affichage en apparence d'arbre terminée en " & Timer - deb & " secondes)"
  End If
 End If
End Sub
 
 
 
Private Sub Label1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  ' ceci uniquement pour ceux (les curieux) qui souhaiteraient en savoir plus sur ce fichier
  ' j'ouvre alors simplement l'explorateur à la sélection faite
  ' en le quittant, ils reviendront au point de départ
  On Error Resume Next ' --->> gestion d'erreur si vous nêtes pas autoriser à ouvrir l'explorateur
   Shell "explorer /select," & Label1.Caption, vbMaximizedFocus
  ' attention : ce geste fera découvrir l'existence réelle de fichiers recensés par Dir,
  ' mais que Windows ne voudra pas (il a SES raisons) qu'ils soient vraiment connus (vous aurez quelques
  ' petites surprises) ou qui sont des "images ISO" que vous avez créées là.
  ' un petit "coucou" à ce propos à quelqu'un qui devrait se reconnaître au passage (n'est-pas, l'ami ?)
  If Err Then MsgBox "vous n'êtes pas autorisé à ouvrir l'explorateur<. Voyez cela avec le responsable informatique"
  On Error GoTo 0
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
  ' Je  vais vous faire grâce d'explications trop détaillées sur les instructions qui suivent.
  ' Elles sont à la portée de tout développeur et n'ont pas grand-chose à voir avec l'utilisation
  ' de la fonction Dir (l'objet réel de cet outil)
  ' Elles ne sont qu'une série de "remontées" classiques, de colonne en colonne, coomppagnées d'une simple
  ' concaténation des données trouvées lors de chaque chaque "remontée ainsi conduite
  If Range("A1").Text = "" Or Target.Cells.Count > 1 Then Exit Sub ' ne pas afficher le label dans ces cas et permettre une sélection éventuelle
  Dim h As Long, toto As String, titi As String, lal As Long
  On Error Resume Next ' pourquoi cette gestion ? car après vidage et avant traitement, on va déclencher
                        ' cet évènement selection_change dans du "vide" -->> et donc générer une erreur !
                        ' je n'ai laissé ici cette gestion que pour faire face au cas où un "mal réveillé" aurait
                        ' cru inutile et effacé ma toute première ligne de l'évènement CommandButton1_Click
                        ' (voir à ce sujet le commentaire que j'y ai mis et un salut à ceux qui s'y reconnaîtraient...)
  If Target.Text = "" Then '|
    Label1.Visible = False '| oter de la vue le label alors inutile, voire encombrant
    Exit Sub '              |
  End If '                  |
  toto = ""
  For h = Target.Column To 1 Step -1 '---------------------------------------------
    If Target.Offset(0, -h + 1).Text <> "" Then '                                  |
      titi = Target.Offset(0, -h + 1).Text '                                       |Je remonte, de colonne en colonne,
    Else '                                                                         |chercher le dernier "noeud" connu
      lal = Target.Offset(0, -h + 1).End(xlUp).Row '                               |dans la colonne et concatène mes
      titi = Cells(lal, Target.Offset(0, -h + 1).Column).Value '                   |résultats
      If Err Then MsgBox Err.Number & "  " & Err.Description & "  " & Target.Text '|                                 |
    End If '                                                                       |
    toto = toto & "\" & titi '                                                     |
  Next '---------------------------------------------------------------------------
  On Error GoTo 0
 
  ' Il nous reste plus qu'à positionner notre label dont le caption est celui de la concaténation
  ' obtenue par nos "remontées". C'est tout.
 
  With Label1
    .Visible = True
    .Left = 0
    .Top = Target.Top - 1.1
    .Caption = Mid(toto, 2)
    .TextAlign = fmTextAlignCenter
    .Font.Name = Target.Font.Name
    .Font.Size = Target.Font.Size + 1
    .Height = Target.Height + 4.3
    .ForeColor = vbRed
    .Width = Target.Offset(0, 5).Left
  End With
End Sub

module standard :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Option Explicit
 
Public Sub on_lance(DS As String, A As Integer, F_F As String, F_FI As String, F_D As String, F_DI As String)
  Dim L_D As Boolean, LD_I As Boolean, T_F_F, T_F_FI, T_F_D, T_F_DI, i As Long, k As Long, derlig As Long, dercol As Long, T_C As New Collection, lt, CT_I As Boolean
  ActiveSheet.Label1.Visible = False
  If F_F = "" Then F_F = "*"
  If F_D = "" Then F_D = "*": L_D = True
  T_F_F = Split(UCase(F_F), ":")
  If F_FI <> "" Then
    T_F_FI = Split(UCase(F_FI), ":")
    CT_I = True
  Else
    CT_I = False
  End If
 
  '****** 25/01/16 ******
  If F_DI <> "" Then
    T_F_DI = Split(UCase(F_DI), ":")
    LD_I = True
  Else
    LD_I = False
  End If
  '****** fin 25/01/16 ****
 
  If F_D <> "*" Then T_F_D = Split(UCase(F_D), ":")
  'Dim i As Long, k As Long, derlig As Long, dercol As Long, T_C As New Collection, lt
 
  For i = 1 To T_C.Count '--  on s'assure de vider la collection tremplin T_C
    T_C.Remove (1) '        | une interruption inopinée pourrait y avoir
  Next '--------------------  laissé traîner des éléments
 
  ReDim lt(0) ' on s'assure de vider la matrice lt
 
  T_C.Add DS ' on ajoute ici à notre collection T_C le chemin du dossier à traiter
  ' le bloc qui suit ne sera exécuté que lorsque la collection tremplin commencera à être remplie
  ' par l'appel de la procédure on_traite (puisque l'on examine sans cesse son état)
 
  '==========================================================================================
  Do While T_C.Count > 0 '==================================================================
    For i = T_C.Count To 1 Step -1 '                                                        # voilà ce que je baptise
      on_traite T_C(i), A, lt, T_C, T_F_F, T_F_FI, T_F_D, T_F_DI, L_D, CT_I, LD_I 'cet appel aura DEUX effets :        # "traitement en poupées gigognes"
                                                       'traitement d 'un élément de T_C     # Son mécanisme pourra paraître
                                                       'dans la foulée, abondement de       # complexe. Il n'en est rien.
                                                       ' T_C (et ainsi de suite)            #                            |
      T_C.Remove (i)  ' chaque fois qu'un élément de T_C a ainsi été traité, on le supprime # Prenez le temps de l'analyser.
    Next '                                                                                  #
  Loop '====================================================================================
   '==========================================================================================
 
 
  On Error Resume Next ' cette gestion est indispensable car la méthode transpose a une limite de colonnes à traiter
   Range("A1:A" & UBound(lt, 1)).Value = WorksheetFunction.Transpose(lt) ' on profite de transpose SI possible
 
   If Err Then ' uniquement si Transpose a échoué, donc -->>
    ReDim lt1(0 To UBound(lt) + 1, 1 To 2) '---  nous faisons alors nous-mêmes le boulot
    For i = 0 To UBound(lt) + 1 '              | que transpose n'a pu faire
     lt1(i, 1) = lt(i) '                       | nous alimentons un tableau de deux colonnes
    Next '                                     | dont il nous suffit maintenant de passer
    Range("A1:A" & UBound(lt)).Value = lt1 '---  tout simplement les valeurs à la colonne A
   End If
 
End Sub
Public Sub on_traite(DS As String, A As Integer, lt, T_C As Collection, T_F_F, T_F_FI, T_F_D, T_F_DI, L_D As Boolean, CT_I As Boolean, LD_I As Boolean)
  Dim N_E As String, CH As String, FDS As String, bon As Boolean, i As Integer
  If Right(DS, 1) <> "\" Then DS = DS & "\"
  FDS = Split(DS, "\")(UBound(Split(DS, "\")) - 1)
  On Error Resume Next ' cette gestion est IMPORTANTE (voir commentaires *** à la ligne suivante)
   N_E = Dir$(DS, A) '***** dir pourrait se "planter" sur des dossiers innaccesibles
 
   'Ce qui suit n'est jamais que l'utilisation la plus classique de la fonction Dir appliquée à un dossier
   ' je n'y commente donc que ce que nous faisons des résultats du parcours de ce seul dossier ou sous-dossier
   Do While N_E <> ""
     If N_E <> "." And N_E <> ".." Then
       CH = DS & N_E
       'On Error Resume Next ' hé oui ! cas d'innaccessibilité éventuelle (dossier alors recensé, mais pas son contenu)
 
       '============================= S'IL S'AGIT D'UN SOUS - DOSSIER ==========================================
        If GetAttr(CH) And vbDirectory Then '***** getattr pourrait se planter sur certains dossiers, voire fichiers spécifiques
            '****** 25/01/16 ******
            ' répertoires non voulu
            bon = True
            If LD_I Then
              For i = 0 To UBound(T_F_DI)
                If UCase(N_E) Like UCase(T_F_DI(i)) Then
                   bon = False: Exit For
                End If
              Next
            End If
 
            If bon Then T_C.Add DS & N_E ' ->> on ajoute une poupée gigogne à T_C
            '****** fin 25/01/16 ****
 
         'Regardez bien le deux lignes de codes sui suivent et que j'ai mises en commentaires :
         'selon qu'on les commente ou qu'on les décommente, les sous-dossiers apparaîtront de
         'manière séparée ou n'apparaîtront qu'accompagnés du 1er fichier trouvé
         'j'estime personnellement que leur affichage "séparé" n'apporte rien et occupe de la place, mais
         'vous pouvez en juger autrement (il vous suffira alors de décommenter ces deux lignes)
 
                         'lt(UBound(lt)) = CH   '  on alimente notre matrice générale
                         'ReDim Preserve lt(UBound(lt) + 1) ' et on la redimensionne pour y mettre l'élément suivant
 
       '============================= S'IL S'AGIT D'UN FICHIER ==========================================
        Else
           bon = True
 
           If Not L_D Then ' inutile de contrôler si pas de filtre/dossier
              bon = False
              For i = 0 To UBound(T_F_D)
                If UCase(FDS) Like UCase(T_F_D(i)) Then bon = True: Exit For
              Next
            End If
 
            If bon = True Then ' on ne contrôle par rapport au filtre/fichier que si on est encore à true
              If CT_I Then
                For i = 0 To UBound(T_F_FI)
                  If UCase(N_E) Like UCase(T_F_FI(i)) Then
                     bon = False: Exit For
                  End If
                Next
              End If
              If bon = True Then
                For i = 0 To UBound(T_F_F)
                  If UCase(N_E) Like UCase(T_F_F(i)) Then
                     lt(UBound(lt)) = CH '  on alimente notre matrice générale
                     ReDim Preserve lt(UBound(lt) + 1) ' et on la redimensionne pour y mettre l'élément suivant
                     Exit For
                  End If
                Next
              End If
            End If
          End If
       End If
     N_E = Dir
   Loop
End Sub

eric

Utilisation récursive de dir (tous sous-dossiers et fichiers d'un volume ou répertoire)

Contribuez

Discussions similaires

Partager

Partager