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 |
Partager