'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'collection sub et fonction avec récursivité
'liste recursive d'un dossier avec lecture des propriétés
'date 18/08/2024
'librairie utilise shell Automation( en late binding)
'auteur :patricktoulon
'version :4
Sub test_V4()
Dim chemin, table(), cel As Range, rowCount As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
chemin = .SelectedItems(1)
Else
Exit Sub
End If
End With
ListeProprietesFichiers_getDetailsOf_V4 chemin, table
Feuil2.Cells.Clear
Feuil2.Activate
Application.ScreenUpdating = False
With Feuil2.[a1].Resize(UBound(table, 2), 11) ' Redimensionnement dynamique
.Value = Application.Transpose(table)
.VerticalAlignment = xlCenter
For Each cel In .Columns(1).Cells
If cel.Text Like "DOSSIER:*" Then
cel.Font.Color = vbRed
cel.Font.Bold = True
ActiveSheet.Hyperlinks.Add Anchor:=cel.Offset(, 10), Address:=cel.Offset(, 10).Text, TextToDisplay:="DOSSIER : " & cel.Offset(, 10).Text
With cel.Resize(, 11)
.Font.Bold = True
.Font.Size = 13
End With
Else
ActiveSheet.Hyperlinks.Add Anchor:=cel.Offset(, 10), Address:=cel.Offset(, 10).Text, TextToDisplay:=cel.Offset(, 10).Text
End If
Next
Columns.AutoFit
End With
End Sub
Function ListeProprietesFichiers_getDetailsOf_V4(folder, ByRef table, Optional a As Long = 1)
Dim strFileName As Object, objFolder As Object, i As Byte, e As Integer, ProP$
Dim collect As New Collection
Static objShell As Object: Static FsO As Object
If a = 1 Then
a = a + 1
Set objShell = CreateObject("Shell.Application")
Set FsO = CreateObject("Scripting.FileSystemObject")
ReDim table(1 To 11, 1 To a) ' Table redimensionné
table(1, a) = "DOSSIER: " & folder
table(2, a) = FsO.getfolder(folder).Size / 1000 & " Ko"
table(11, a) = folder
End If
Debug.Print folder
Dim qr As Boolean
Set objFolder = objShell.Namespace(folder)
For Each strFileName In objFolder.Items
qr = False
If Not strFileName.IsFolder Then qr = True
'If strFileName.Type = "Dossier compressé" Then qr = True
If Right(strFileName, 4) = ".zip" Then qr = True
If qr Then
a = a + 1
ReDim Preserve table(1 To 11, 1 To a) ' Ajustement dynamique du tableau
For i = 0 To 250
Select Case objFolder.getDetailsOf(objFolder.Items, i)
Case "Nom": table(1, a) = ". " & objFolder.getDetailsOf(strFileName, i): table(1, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Taille": table(2, a) = objFolder.getDetailsOf(strFileName, i): table(2, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Extension du fichier": table(3, a) = objFolder.getDetailsOf(strFileName, i): table(3, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Commentaires": table(4, a) = objFolder.getDetailsOf(strFileName, i): table(4, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Modifié le": table(5, a) = objFolder.getDetailsOf(strFileName, i): table(5, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Date de création": table(6, a) = objFolder.getDetailsOf(strFileName, i): table(6, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Date d’accès": table(7, a) = objFolder.getDetailsOf(strFileName, i): table(7, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Sorte": table(8, a) = objFolder.getDetailsOf(strFileName, i): table(8, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Notation": table(9, a) = objFolder.getDetailsOf(strFileName, i): table(9, 1) = objFolder.getDetailsOf(objFolder.Items, i)
Case "Auteurs": table(10, a) = objFolder.getDetailsOf(strFileName, i): table(10, 1) = objFolder.getDetailsOf(objFolder.Items, i)
'Case "Chemin du dossier": table(a, 11) = objFolder.getDetailsOf(strFileName, i): table(1, 10) = objFolder.getDetailsOf(objFolder.Items, i)
End Select
Next
table(11, 1) = "path"
' Ajoute d'autres colonnes selon les besoins
table(11, a) = strFileName.Path
Else
collect.Add strFileName.Path
End If
Next
Dim subfolder
For Each subfolder In collect
a = a + 1
ReDim Preserve table(1 To 11, 1 To a)
table(1, a) = "DOSSIER: " & subfolder
On Error Resume Next
table(2, a) = FsO.getfolder(subfolder).Size / 1000 & " Ko"
On Error GoTo 0
table(11, a) = subfolder
ListeProprietesFichiers_getDetailsOf_V4 subfolder, table, a
Next
ListeProprietesFichiers_getDetailsOf_V4 = table ' Retourne le nombre de lignes utilisées
End Function
