Sub TestClasseurs()
Dim Dossier As Object, Fichier As Object
Dim Chemin As String, CeFichier As String
Dim TabDossiers As Variant
Dim L As Long, D As Long
Dim MemAskL As Boolean
Application.ScreenUpdating = False
CeFichier = ThisWorkbook.Name
'Empêcher les alertes de lien à l'ouverture des classeurs
MemAskL = Application.AskToUpdateLinks
Application.AskToUpdateLinks = False
L = 1
'Création du tableau des sous-dossiers existants
TabDossiers = lstDossiers(ThisWorkbook.Path, True)
For D = 1 To UBound(TabDossiers)
'Chemin du dossier (ou sous-dossier) à analyser
Chemin = TabDossiers(D) & '\'
'Analyse du dossier (ou sous-dossier)
Set Dossier = CreateObject('Scripting.FileSystemObject').GetFolder(Chemin)
For Each Fichier In Dossier.Files
If Fichier.Name <> CeFichier Then
'Liste les fichiers Excel
If Right(Fichier.Name, 3) = 'xls' Then
L = L + 1
'Empêche les macros à l'ouverture
Application.EnableEvents = False
Workbooks.Open Chemin & Fichier.Name
With ThisWorkbook.Sheets('Test')
.Cells(L, 1) = IIf(ContientMacros(ActiveWorkbook), 'OUI', '')
.Cells(L, 2) = IIf(ContientLiens(ActiveWorkbook), 'OUI', '')
.Cells(L, 3) = Chemin
.Cells(L, 4) = Fichier.Name
End With
ActiveWorkbook.Close False
Application.EnableEvents = True
End If
End If
Next
Next D
Set Dossier = Nothing
'Rétablit l'alerte de lien éventuelle dans les options Excel
Application.AskToUpdateLinks = MemAskL
Application.ScreenUpdating = True
MsgBox L & ' classeurs trouvés !'
End Sub
'______________________________________________________________________________________
Private Function lstDossiers(Chemin As String, Optional Debut As Boolean) As Variant
Dim Dossier As Object, SD As Object, D As Object
Static TabTemp() As String
If Debut Then
ReDim TabTemp(1 To 1)
TabTemp(1) = Chemin
End If
Set Dossier = CreateObject('Scripting.FileSystemObject').GetFolder(Chemin)
'examen du dossier courant
For Each D In Dossier.subfolders
ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1)
TabTemp(UBound(TabTemp)) = D.Path
Next
'Traitement récursif des sous-dossiers (d'après un code de F.Sigonneau)
For Each SD In Dossier.subfolders
lstDossiers SD.Path
Next SD
lstDossiers = TabTemp()
Set Dossier = Nothing
End Function
'______________________________________________________________________________________
Private Function ContientMacros(Classeur As Workbook) As Boolean
Dim Obj As Object
For Each Obj In Classeur.VBProject.VBComponents
With Obj.CodeModule
ContientMacros = .CountOfDeclarationLines + 1 < .CountOfLines
End With
If ContientMacros Then Exit For
Next Obj
End Function
'______________________________________________________________________________________
Private Function ContientLiens(Classeur As Workbook) As Boolean
ContientLiens = Not IsEmpty(Classeur.LinkSources)
End Function