'/////////////////////////////////////////////////
'/// Nécessite les références aux librairies ///
'/// ///
'/// Library IWshRuntimeLibrary ///
'/// C:\WINDOWS\system32\wshom.ocx ///
'/// Windows Script Host Object Model ///
'/// ///
'/// Library Shell32 ///
'/// C:\WINDOWS\system32\SHELL32.dll ///
'/// Microsoft Shell Controls And Automation ///
'/////////////////////////////////////////////////
'###############################################
'### Constante du dossier éligible à adapter ###
Const DOSSIER As String = "C:\0\Mes bidouilles"
'### Constante de l'auteur du .xls à adapter ###
Const AUTEUR As String = "Patrick Morange"
'###############################################
Const AUTHOR As Long = 9
Dim TabDossier()
Dim nbFolders&
'________________________________________
Sub FichiersXlsDansDossiers()
Dim FSO As IWshRuntimeLibrary.FileSystemObject
Dim F As IWshRuntimeLibrary.Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
Set F = FSO.GetFolder(DOSSIER)
If Len(Trim(DOSSIER)) < 4 Then Exit Sub
nbFolders& = nbFolders& + 1
ReDim TabDossier(1 To nbFolders&)
TabDossier(nbFolders&) = DOSSIER
Call EnumereSousDossier(F)
Set F = Nothing
Set FSO = Nothing
Call PropertyAuthorXLS
nbFolders& = 0
End Sub
'________________________________________
Sub EnumereSousDossier(F As IWshRuntimeLibrary.Folder)
Dim SubFolder As IWshRuntimeLibrary.Folder
For Each SubFolder In F.SubFolders
nbFolders& = nbFolders& + 1
ReDim Preserve TabDossier(1 To nbFolders&)
TabDossier(nbFolders&) = SubFolder.Path
'--- Récursivité pour les sous-dossiers ----
Call EnumereSousDossier(SubFolder)
Next SubFolder
Set SubFolder = Nothing
End Sub
'________________________________________
Sub PropertyAuthorXLS(Optional dummy As Byte)
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Dim FI As Shell32.FolderItem
Dim T()
Dim i&
Dim j&
Set SH = CreateObject("Shell.Application")
For i& = 1 To UBound(TabDossier)
Set F = SH.Namespace(TabDossier(i&))
For Each FI In F.Items
If Not FI.isFolder Then
If LCase(Right(FI.Name, 4)) = ".xls" Then
If F.getDetailsOf(FI, AUTHOR) = AUTEUR Then
j& = j& + 1
ReDim Preserve T(1 To 3, 1 To j&)
T(1, j&) = FI.Path
T(2, j&) = FI.Name
T(3, j&) = F.getDetailsOf(FI, AUTHOR)
End If
End If
End If
Next FI
Next i&
If j& > 0 Then
'--- Inscription des résultats dans une nouvelle feuille ---
Sheets.Add
Range(Cells(1, 1), Cells(UBound(T, 2), UBound(T, 1))) = Application.WorksheetFunction.Transpose(T)
'--- ou alors votre traitement ... ???
'Ma Macro
Else
MsgBox "Aucun classeur de l'auteur ''" & AUTEUR & "'' n'a été trouvé."
End If
Set FI = Nothing
Set F = Nothing
Set SH = Nothing
End Sub