Option Explicit
Sub ScanClasseurs()
'ATTENTION : nécessite une référence à la librairie
'Microsoft Visual Basic For Applications Extensibility 5.3
'myDearFriend! - Septembre 2006
Dim Dossier As Object, Fichier As Object
Dim TabDossiers As Variant, Rep As Variant
Dim C As Range
Dim Chemin As String
Dim L As Long, D As Long
[COLOR="Blue"]Dim sh As Variant[/COLOR]
Rep = Application.InputBox("entrez le nom du répertoire à explorer", "Chemin du répertoire", _
"D:\_PC033_prb\Dokumentation\Daten\daten_prb\Schlamm\EMSR_Doku\", Type:=2)
If Rep = False Then Exit Sub
If Not Rep Like "*\?*" Then
MsgBox "Veuillez indiquer un dossier (pas un disque)!"
Exit Sub
End If
Application.ScreenUpdating = False
'Création du tableau des sous-dossiers existants
TabDossiers = lstDossiers(Rep, 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)
[COLOR="blue"]For Each sh In Sheets[/COLOR]
For Each Fichier In Dossier.Files
'Liste les fichiers Excel
If Fichier.Name Like "*.xls" Then
Set C = [COLOR="Blue"]sh[/COLOR].Columns(3).Find(Left(Fichier.Name, Len(Fichier.Name) - 4), _
LookIn:=xlValues)
If Not C Is Nothing Then
[COLOR="blue"]Sheets("11").[/COLOR]Hyperlinks.Add Anchor:=C.Offset(0, 1), Address:=Fichier.Path, _
TextToDisplay:=Fichier.Name
[COLOR="Red"]' TextToDisplay:=C.Offset(0, 26)[/COLOR]
L = L + 1
End If
End If
Next
[COLOR="blue"] Next sh[/COLOR]
Next D
Set Dossier = Nothing
Application.ScreenUpdating = True
MsgBox "Traitement terminé !" & vbLf & L & " lien(s) créé(s)"
End Sub
Private Function lstDossiers(ByVal 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
