Je voudrais créer un répertoire des différent dossiers, sous dossiers, fichiers de mon ordinateur avec des liens hypertextes pointant sur les fichiers.

sub remplir(RepertParent, ExtFichier)
 ' Remplit la feuille courante avec le contenu du répertoire RepertParent
 ' Les noms de répertoires sont placés dans la colonne active à partir de la
 ' cellule active
 ' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
 ' colonne de gauche
 ' il reste a écrire la section date et heure 14/02/2000 18:30
 
 Dim Compteur As Integer
 Dim NbreRepert As Integer
 Dim LeFichier As String
 Dim LeDossier As String
 Dim ExtLocale As String
 Dim ParentLocal As String
 Dim LeDossierLocal() As String
 
 ExtLocale = ExtFichier
 LeFichier = Dir(RepertParent & ExtFichier)
 If Len(LeFichier) = 0 Then
  ActiveCell.Value = RepertParent
  ActiveCell.Offset(1, 0).Select
 End If
 Do While Len(LeFichier) <> 0
  ActiveCell.Value = RepertParent
  ActiveCell.Offset(0, 1).Select
  ActiveCell.Value = LeFichier
  ActiveCell.Offset(1, -1).Select
  LeFichier = Dir
 Loop
 'Compter le nombre de sous-répertoires
 NbreRepert = 0
 LeDossier = Dir(RepertParent, vbDirectory)
 Do While LeDossier <> ""
  If LeDossier <> "." And LeDossier <> ".." Then
    If (GetAttr(RepertParent & LeDossier) And vbDirectory) = vbDirectory Then
      NbreRepert = NbreRepert + 1
    End If
  End If
  LeDossier = Dir
 Loop
 ReDim LeDossierLocal(NbreRepert + 1)
 Compteur = 1
 LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
 Do While LeDossierLocal(Compteur) <> ""
  If LeDossierLocal(Compteur) <> "." And LeDossierLocal(Compteur) <> ".." Then
    If (GetAttr(RepertParent & LeDossierLocal(Compteur)) And vbDirectory) = vbDirectory Then
      Compteur = Compteur + 1
    End If
  End If
  LeDossierLocal(Compteur) = Dir
 Loop
 For Compteur = 1 To UBound(LeDossierLocal()) - 1
  ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
  Call remplir(ParentLocal, ExtLocale)
 Next
 end sub

sub mondir()
 Dim LeChemin As String
 Dim Lextension As String
 Dim LeTitre As String
 Dim LeMessage As String
 Dim Arret As Boolean
 
 LeTitre = "Répertoires et sous-répertoires"
 LeMessage = "Taper le nom complet du répertoire"
 Arret = False
 
 Do
 LeChemin = InputBox(LeMessage, LeTitre, LeChemin)
 If Len(LeChemin) = 0 Then
  Arret = True
 Else
  If Mid(LeChemin, Len(LeChemin), 1) <> "" Then
    LeChemin = LeChemin + ""
  End If
  If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
    Lextension = InputBox("Taper le type de fichier à afficher",
 LeTitre, "*.*")
    Call remplir(LeChemin, Lextension)
    Arret = True
  Else
    LeMessage = "Répertoire introuvable...Recommencer ?"
  End If
 End If
 Loop Until Arret
 end sub