Nombre et taille de tous les classeurs Excel de mon ordi !

Le
garnote
Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichDenis
Le #19849591
Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote"
Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge
garnote
Le #19849811
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis"
Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge



garnote
Le #19849891
C'est OK pour le fichier texte mais là, j'en ai plus que voulu.
Je ne veux que les fichiers .xls avec nombre et taille.
J'aimerais bien que ça prenne une forme un peu semblable
à celle obtenue par mes macros.
Mais bon, ce n'est pas grave. Ce n'était qu'un exercice de VBA
pour explorer les répertoires.

Merci et A+

Moé

"garnote" %
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis"
Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge







MichDenis
Le #19850261
Si tu ne veux que les fichiers soient dans excel, que ta volonté soit faite !
;-)

dir c:*.xls* /s/n/o >c:Test.xls

à la limite, tu peux même actionner la commande à partir d'une macro :
'----------------------------------
Sub Afficher_les_Fichiers_Excel()
Shell "command.com /c dir c:*.xls /s/b >C:test.xls", vbHide
End Sub
'----------------------------------

Dis moi, quoi vouloir de plus ?
;-))




"garnote"
C'est OK pour le fichier texte mais là, j'en ai plus que voulu.
Je ne veux que les fichiers .xls avec nombre et taille.
J'aimerais bien que ça prenne une forme un peu semblable
à celle obtenue par mes macros.
Mais bon, ce n'est pas grave. Ce n'était qu'un exercice de VBA
pour explorer les répertoires.

Merci et A+

Moé

"garnote" %
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis"
Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge







garnote
Le #19850441
> Dis moi, quoi vouloir de plus ?


Rien pantoute :-)
Par contre, si tu fais une tournée provinciale Excel
pour dépatouiller les pataugeurs de mon espèce,
n'oublie pas de passer par Québec; je serai aux
premières loges !




"MichDenis" %
Si tu ne veux que les fichiers soient dans excel, que ta volonté soit
faite !
;-)

dir c:*.xls* /s/n/o >c:Test.xls

à la limite, tu peux même actionner la commande à partir d'une macro :
'----------------------------------
Sub Afficher_les_Fichiers_Excel()
Shell "command.com /c dir c:*.xls /s/b >C:test.xls", vbHide
End Sub
'----------------------------------

Dis moi, quoi vouloir de plus ?
;-))




"garnote" discussion :

C'est OK pour le fichier texte mais là, j'en ai plus que voulu.
Je ne veux que les fichiers .xls avec nombre et taille.
J'aimerais bien que ça prenne une forme un peu semblable
à celle obtenue par mes macros.
Mais bon, ce n'est pas grave. Ce n'était qu'un exercice de VBA
pour explorer les répertoires.

Merci et A+

Moé

"garnote" %
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis"
Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge










MichDenis
Le #19851691
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'---------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String
Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 0
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx", "xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------
MichDenis
Le #19851681
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'-------------------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String

Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 1
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx", "xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------
J
Le #19851771
Bonjour à tous
Enfin quelque chose de simple! C'est vrai qu'en ligne commande, c'était
un peu difficile pour Serge ;-)
Rien que pour saisir ton code, Denis, je dois rajouter une barrette de
RAM ;-)
Bonne journée à vous 2.
Amicalement
J@@

MichDenis a écrit :
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'-------------------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String

Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 1
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx", "xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------






garnote
Le #19851831
> Enfin quelque chose de simple! C'est vrai qu'en ligne commande, c'était un
peu difficile pour Serge ;-)


:-)))
À mon âge et avec le temps de chien qu'il fait à Québec, je dois
avouer que j'ai de gros problèmes de dos.
D'ailleurs, quand je sors de cellule, j'ai de la difficulté à m'adapter !

Serge



"J@@" ejQMq$
Bonjour à tous
Enfin quelque chose de simple! C'est vrai qu'en ligne commande, c'était un
peu difficile pour Serge ;-)
Rien que pour saisir ton code, Denis, je dois rajouter une barrette de
RAM ;-)
Bonne journée à vous 2.
Amicalement
J@@

MichDenis a écrit :
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'-------------------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String

Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 1
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type",
"Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx",
"xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated,
_
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value =
Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------







Misange
Le #19853721
garnote a écrit :
n'oublie pas de passer par Québec; je serai aux
premières loges !



j'y serai demain soir :-)
Misange migrateuse
http://www.excelabo.net : Participez à un travail collaboratif sur excel !
Publicité
Poster une réponse
Anonyme