Sub CreerLiensAuto()
'---------------------------------------------------------------------------------------
' myDearFriend! - 07/11/2005
' Création Auto de Liens Hypertextes
'---------------------------------------------------------------------------------------
'ATTENTION : nécessite une référence à la librairie
'Microsoft Visual Basic For Applications Extensibility 5.3
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
Application.ScreenUpdating = False
ThisWorkbook.Sheets('Test').Range('A2:A65536').ClearContents
CeFichier = ThisWorkbook.Name
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
L = L + 1
'MAJ feuille Excel
With ThisWorkbook.Sheets('Test')
.Cells(L, 1) = Chemin
.Hyperlinks.Add Anchor:=.Cells(L, 1), Address:= _
Chemin & Fichier.Name, TextToDisplay:=Fichier.Name
End With
End If
Next
Next D
Set Dossier = Nothing
Set Fichier = Nothing
Application.ScreenUpdating = True
MsgBox L - 1 & ' fichiers 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
Set SD = Nothing
Set D = Nothing
End Function