Lecture d'une répertoire disque

Bonjour,


Sub arborescence()
racine = ChoixDossier() ' ou un répertoire C:xxx e.g.
If racine = "" Then Exit Sub
Range("A:E").Clear
Range("A3").Select
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(racine)
Lit_dossier dossier_racine, 1
Range("A1").Select
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
ActiveCell.Value = decal(niveau - 1) & dossier.Name & "[" &
dossier.Path & "]"
ActiveCell.Interior.ColorIndex = 36
ActiveCell.Offset(1, 0).Select
For Each d In dossier.SubFolders
Lit_dossier d, niveau + 1
Next
For Each f In dossier.Files
nom_fich = f.Name
ActiveCell = decal(niveau) & f.Name
ActiveCell.Offset(0, 1) = f.Size
ActiveCell.Offset(0, 2) = f.DateLastModified
ActiveCell.Offset(0, 3) = f.Attributes
If f.Attributes And vbHidden Then ActiveCell.Offset(0, 4) =
"Caché"
ActiveCell.Interior.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Next
End Sub

Function decal(niv)
decal = String(3 * niv, " ")
End Function

Function ChoixDossier()
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & ""
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
Else
ChoixDossier = InputBox("Répertoire?")
End If
End Function

Cordialement JB

http://boisgontierj.free.fr/pages_site/GestionRepertoire.htm


On 9 fév, 14:54, "Blaise Cacramp" <non.val...@gmail.cam> wrote:

Hello

J'ai souvenir d'avoir lu ici il y a quelques mois une procédure VBA pour
lire le répertoires d'un disque (dossiers, sous-dossiers, ...)

Mais je ne vois plus...

Merci !

Copie ce qui suit dans un module standard.
Assure toi que la déclaration des variables et des API
soient en haut du module.


'Attention à bien mettre un antislash à la fin du le nom du répertoire
'dans l'appel de Recurse.
'Laurent Longre, mpfe
'========================================================
Option Compare Text

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
(ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Const Masque = "*.*"

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String

Sub Test()
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse "C:Denis"
Application.ScreenUpdating = False
With Range("A1").Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort [A1]
.EntireColumn.AutoFit
End With
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
If Chemin <> "D:" Then
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub










"Blaise Cacramp" <non.valide@gmail.cam> a écrit dans le message de news:
eFdwdHFTHHA.4276@TK2MSFTNGP02.phx.gbl...
Hello

J'ai souvenir d'avoir lu ici il y a quelques mois une procédure VBA pour
lire le répertoires d'un disque (dossiers, sous-dossiers, ...)

Mais je ne vois plus...


Merci !

Un petit détail :
la déclaration de la constante Masque permet d'obtenir
une liste restrictive sur le type de fichier que tu désires obtenir

'Tous les fichiers
Const Masque = "*.*"

'Seulement les fichiers Excel
Const Masque = "*.xls"


"MichDenis" <michdenis@hotmail.com> a écrit dans le message de news:
eBpZb7FTHHA.5068@TK2MSFTNGP03.phx.gbl...
Copie ce qui suit dans un module standard.
Assure toi que la déclaration des variables et des API
soient en haut du module.


'Attention à bien mettre un antislash à la fin du le nom du répertoire
'dans l'appel de Recurse.
'Laurent Longre, mpfe
'========================================================
Option Compare Text

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
(ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Const Masque = "*.*"

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String

Sub Test()
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse "C:Denis"
Application.ScreenUpdating = False
With Range("A1").Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort [A1]
.EntireColumn.AutoFit
End With
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
If Chemin <> "D:" Then
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub










"Blaise Cacramp" <non.valide@gmail.cam> a écrit dans le message de news:
eFdwdHFTHHA.4276@TK2MSFTNGP02.phx.gbl...
Hello

J'ai souvenir d'avoir lu ici il y a quelques mois une procédure VBA pour
lire le répertoires d'un disque (dossiers, sous-dossiers, ...)

Mais je ne vois plus...


Merci !