Macro lien hypertexte

'RECUPERATION REPERTOIRES ET NOMS DE FICHIERS DANS UN CLASSEUR
'office2007
Option Explicit
Public chem As String
Sub AfficheFichiersEtChemins()
Dim LeChemin, LeMessage As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean
' Pour éviter un "autochargement" des fichiers
Range("a:a").ClearContents

  LeTitre = "Répertoires et sous-répertoires"
  Arret = False
  Application.ScreenUpdating = True
   Range("A1").Activate
  Do
 chem = ChoisirDossier

    If Len(chem) = 0 Then
      Arret = True
    Else
      If Mid(LeChemin, Len(chem), 1) <> "\" Then
        chem = chem + "\"
      End If
      If Len(Dir(chem, vbDirectory)) <> 0 Then
        Lextension = "*.*"
         Call Remplir(chem, Lextension)
        Arret = True
      Else
        LeMessage = "Répertoire introuvable...Recommencer ?"
      End If
    End If
  Loop Until Arret
  
End Sub
Private 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 droite
' 14/02/2000 18:30, Gérard B, mpfe

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, 1).Select
    End If
    Do While Len(LeFichier) <> 0
        'ActiveCell.Value = (RepertParent & LeFichier)
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.Value = LeFichier
         ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        chem & "\" & LeFichier, TextToDisplay:=LeFichier
       ' ActiveCell.Offset(0, 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
Function ChoisirDossier()
    Dim objShell, objFolder, chemin As String, SecuriteSlash
                                            
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisissez un répertoire", &H1&)
    On Error Resume Next
    chemin = objFolder.Items.Item.Path

    SecuriteSlash = InStr(objFolder.Title, ":")

    If SecuriteSlash > 0 Then
        chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
    End If
    ChoisirDossier = chemin
End Function

Private Sub CommandButton1_Click()
AfficheFichiersEtChemins
End Sub