XL 2010 RESOLU [VBA] Lister les fichiers d'une arborescence au choix

ralph45

XLDnaute Impliqué
Bonjour le forum,

Avec le fichier en PJ, j'aimerai lister tous les fichiers (quelle que soit leur extension) d'un répertoire que j'aurai préalablement choisi avec le 1er bouton "Choix de dossier".

Pour chaque fichier recensé, j'aimerai voir apparaitre les informations suivantes :
- nom du fichier,
- son extension,
- sa taille (poids informatique),
- ses dates de création et de modification,
- et son chemin complet.

En espérant avoir été clair et exhaustif, je vous remercie d'avance.
NB : j'étais tombé sur une discussion qui traitait bien du sujet, mais impossible de la retrouver ! :confused:
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonsoir.
Essayez ça, déjà :
VB:
Private Sub CommandButton1_Click()
   Dim Chemin As String, NomFic As String, T(1 To 5000, 1 To 6), L As Long
   With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count > 0 Then Chemin = .SelectedItems(1)
      End With
   ChDrive Chemin: ChDir Chemin
   NomFic = Dir("*.*")
   While NomFic <> ""
      L = L + 1: T(L, 1) = NomFic: T(L, 2) = Split(NomFic, ".")(1): T(L, 3) = FileLen(NomFic): T(L, 5) = FileDateTime(NomFic)
      T(L, 6) = CurDir & "\" & NomFic
      NomFic = Dir: Wend
   Me.[A3].Resize(UBound(T, 1), UBound(T, 2)).Value = T
   End Sub
 

ralph45

XLDnaute Impliqué
Bonjour le Forum,

@Dranreb

Ton code fonctionne parfaitement, mais pas de façon exhaustive :
c'est dû au fait que je me suis mal exprimé dans ma demande...

Il faudrait lister tous les fichiers se trouvant dans des dossiers contenant eux-mêmes des sous-dossiers, etc.
Bref, un référencement de poupées russes !
La partie de ton code "T(1 To 5000...) sera, de fait, largement dépassée (escompter plutôt en dizaine de milliers de lignes, ou plus).

Merci pour ton aide !
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Activez la référence Microsoft Scripting Runtime et essayez comme ça :
VB:
Option Explicit
Private FSO As New FileSystemObject
Private Sub CommandButton1_Click()
   Dim Chemin As String, NomFic As String, CLnDoss As Collection, _
      Doss As Folder, F As File, T(1 To 20000, 1 To 6), L As Long
   With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count = 0 Then Exit Sub
      Set CLnDoss = SousDoss(FSO.GetFolder(.SelectedItems(1)))
      End With
   On Error Resume Next
   For Each Doss In CLnDoss
      For Each F In Doss.Files
         L = L + 1: T(L, 1) = F.Name: T(L, 2) = Split(F.Name & ".", ".")(1): T(L, 3) = F.Size
         T(L, 4) = F.DateCreated: T(L, 5) = F.DateLastModified
         T(L, 6) = F.Path: Next F, Doss
   Me.[A3].Resize(UBound(T, 1), UBound(T, 2)).Value = T
   End Sub
Function SousDoss(ByVal Doss As Folder) As Collection
   Dim SDos As Folder
   Set SousDoss = New Collection
   SousDoss.Add Doss
   On Error Resume Next
   If Doss.SubFolders.Count = 0 Then Exit Function
   If Err Then Exit Function
   For Each Doss In Doss.SubFolders
      For Each SDos In SousDoss(Doss)
         SousDoss.Add SDos
         Next SDos, Doss
   End Function
 

Discussions similaires


Haut Bas