Option Explicit
Sub Creer_Hyperliens() [COLOR=seagreen]'lancer par un bouton en barre de tache[/COLOR]
Del_Hyperlink [COLOR=seagreen]' pour effacer les liens deja creer car scandisk plante si il reste des liens....[/COLOR]
ScanClasseurs
End Sub
Sub Del_Hyperlink()
Sheets(Array(1, 2, 3, 4, 5, 6, 7, 8, "26", "27", "31", "32", "33", "34", "41", "49", "46-55-56-81-91", 18)).Select
[COLOR=#2e8b57]' tu vois que j'appelle des feuille par leur numero et d'autres par leur nom car avec leur numero ca ne marche pas [/COLOR]
Range("C2:C200").Select
Selection.ClearContents
Range("C2").Select
Sheets(1).Select
End Sub
Sub ScanClasseurs()
[COLOR=seagreen]'myDearFriend! - Septembre 2006[/COLOR]
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
Dim sh As Worksheet
Rep = Application.InputBox("entrez le nom du répertoire à explorer", "Chemin du répertoire", _ "C:\_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
TabDossiers = lstDossiers(Rep, True) [COLOR=seagreen]'Création du tableau des sous-dossiers existants[/COLOR]
For D = 1 To UBound(TabDossiers)
chemin = TabDossiers(D) & "\" [COLOR=seagreen]'Chemin du dossier (ou sous-dossier) à analyser[/COLOR]
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
'Analyse du dossier (ou sous-dossier)
For Each Fichier In Dossier.Files
If Fichier.Name Like "*.xls" [COLOR=#ff0000]And liens casser [/COLOR]Then [COLOR=seagreen]'Liste les fichiers Excel[/COLOR]
For Each sh In Worksheets
Set C = sh.Columns(4).Find(Left(Fichier.Name, Len(Fichier.Name) - 4), _
LookIn:=xlValues)
If Not C Is Nothing Then
sh.Hyperlinks.Add Anchor:=C.Offset(0, -1), Address:=Fichier.Path
C.Offset(0, -1).Value = C.Value
L = L + 1
End If
Next sh
End If
Next
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)
[COLOR=seagreen]'examen du dossier courant[/COLOR]
For Each D In Dossier.subfolders
ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1)
TabTemp(UBound(TabTemp)) = D.Path
Next
[COLOR=seagreen]'Traitement récursif des sous-dossiers (d'après un code de F.Sigonneau)[/COLOR]
For Each SD In Dossier.subfolders
lstDossiers SD.Path
Next SD
lstDossiers = TabTemp()
Set Dossier = Nothing
End Function
