Liens hypertexte

[Gilles]

Bonjour à tous !

Je découvre votre site et je compte bien y revenir fréquemment...

Et , désolé, mais ma 1ère visite va commencer par une question...

Un ami a créé un classeur pour classer son (important) courrier pro, avec des liens hypertexte pour ouvrir chaque référence.
Jusque là, tout va bien...

Mais, où le problème commence, c'est qu'il a refait sa machine, et a rangé différemment (et plus logiquement) ses fichiers, ce qui fait que les liens ne correspondent plus !

Existe-t-il une façon de recréer facilement tous ces liens ou faut-il les refaire 'à la main' un par un ?

Merci et à bientôt
Gilles

 

[myDearFriend!]

Bonsoir Gilles,

Ci-joint, peut-être une solution possible...
Ce classeur exemple est à placer dans le répertoire à analyser. Il créera automatiquement un lien pour chaque fichier présent dans le répertoire cible et sous-répertoires correspondants...

J'ai utilisé le code ci-dessous :

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

Cordialement, [file name=mDF_CreerLiensAuto.zip size=18705]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/mDF_CreerLiensAuto.zip[/file]

 

[Dan]

Bonjour Gilles, Didier,

hmy: Ou làlà Didier, et bien voilà quelque chose qui m'aurait bien servi lorsque j'ai posé ma première question sur ce forum il y a quelques années. Zon m'a pas mal aidé d'ailleurs à ce sujet en me plaçant une appli avec USF pour faire cela.

Pour Gilles, une manière simple que j'ai utilisée pour éviter de retaper les liens :
Dans ton classeur de référence où se trouve les liens hypertextes:
1. Vas dans menu / fichier / propriétés
2. Dans répertoire Web, tapes le lien jusqu'à ton répertoire où se trouve l'ensemble de tes fichiers.

Lorsque tu changeras de nom de répertoire ou de nom de serveur par exemple, il te suffit d'aller changer cette référence.

Cela suppose évidemment que tu gardes la référence de base identique pour tous les fichiers à appeler par lien hypetexte.
exemple : tes fichiers sont placés dans C:\\gilles et tu veux les mettre sur un serveur G:\\Gilles. Il te suffit d'aller changer la référence C par G.

Bon travail

 

[Gilles]

Merci pour votre aide !

Je pense que je vais choisir la solution de Didier.

En effet, dans l'ancienne condiguration, les fichiers étaient répartis dans divers dossiers et sous dossiers, alors que maintenant, ils sont regroupés par type (tous les *.doc dans UN dossier, les *3.xls dans un autre, etc...)

Chaque fichier (par exemple BR05-081-blablablabla.doc) étant représenté dans le classeur comme suit :
BR05-081 | 03-oct.-05 | Destinataire | Objet | Description

Il y aura juste du couper/coller et copier/coller à faire dans les divers onglets pour recréer son classeur à son goût

 

[Jeanlebleu]

Super la création d'un fichier xl pointant sur les fichiers dans les sous-répertoires !

Maintenant on laisse passer quelques mois et on suppose que le fichier 'diverge' :evil: : des fichiers ont été déplacés et on ne sait plus trop les liens encore valables...

D'où ma question :
existe-t-il une solution pour
1. lister les liens hypertextes dans un classeur ?
2. Placer cette dans une feuille indiquant : le lien, la position dans le classeur (feuille, ref cellule) et si le lien est encore actif ?

J'ai bien une petite idée sur comment commencer :
For each F in activeworkbook.sheets
For each H in F.hyperlinks
...
mais après, euh... eh bien

Une idée ?

 

[myDearFriend!]

Bonsoir Jeanlebleu, le fil,

A vrai dire, je ne cerne pas très bien ta demande... lister les liens hypertextes dans un classeur c'est justement l'objectif de cette macro.
Si tu veux être sûr d'avoir une liste exhaustive de liens valables, il suffit simplement de relancer cette macro pour réactualiser l'ensemble... non ? On pourrait d'ailleurs très bien imaginer lancer cette macro automatiquement à chaque ouverture du classeur de référence.

Cordialement,

PS : Très bon début de macro...

 

[Jeanlebleu]

Un petit exemple vaut qu'un long discours.
En utilisant ton oeuvre, j'ai obtenu les fichier d'exemple ci-joint.

Or nous sommes plusieurs à travailler sur les mêmes répertoires et au bout de quelques semaines :
- des fichiers sont déplacés ou supprimés et les liens dans exemple.xls ne sont pas tous mis à jour
- la mise en forme du fichier exemple.xls s'est beaucoup étoffée : plusieurs feuilles, des cadres, des commentaires... et il n'est pas raisonnable de repartir de zéro en utilisant à nouveau ta macro.

Ce que je voudrais c'est auditer le fichier exemple.xls pour obtenir dans une nouvelle feuille la liste de tous les hyperliens :
hyperliens | chemin | actif ou cassé

Suis-je plus clair ?

 

[Jeanlebleu]

oops, le fichier joint avait 6 k de trop ! :whistle: [file name=Exemple_20051116125030.zip size=17563]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Exemple_20051116125030.zip[/file]

 

[myDearFriend!]

Bonsoir Jeanlebleu, le fil,

Tu trouveras ci-joint ton exemple modifié pour tenter de répondre à ta demande...

Par contre, j'ai pensé qu'il serait intéressant également de faire apparaître en couleur rouge les liens rompus dans chacune des feuilles.

La macro ci-dessous applique donc les 2 méthodes :

Sub AuditLiens()
' myDearFriend! - 16/11/2005
Dim F As Worksheet, FCible As Worksheet
Dim Target As Range
Dim Lien As Hyperlink
Dim TabTemp As Variant
Dim L As Long
      Set FCible = Sheets('Controle des Liens')
      With FCible
            .Cells.Delete
            For Each F In Worksheets
                  If F.Name <> .Name Then
                        L = L + 1
                        .Cells(L, 1).Value = 'Feuille ' & UCase(F.Name)
                        For Each Lien In F.Hyperlinks
                              L = L + 1
                              Set Target = .Cells(L, 2)
                              'Partie : MAJ de la feuille d'audit
                              .Hyperlinks.Add Anchor:=Target, Address:=Lien.Address, TextToDisplay:=Lien.TextToDisplay
                              Target.Offset(0, 1) = Lien.Range.Address(False, False)
                              Target.Offset(0, 2) = AuditLien(Lien.Address)
                              'Partie : Affectation de couleur aux liens scannés
                              Lien.Range.Font.ColorIndex = IIf(AuditLien(Lien.Address) = 'Inactif', 3, 5)
                        Next Lien
                  End If
            Next F
            .Range('A').EntireColumn.AutoFit   'Pour feuille d'audit
      End With
End Sub

Private Function AuditLien(A As String) As String
      If UCase(Left(A, 7)) <> 'HTTP://' Then
            AuditLien = IIf(Dir(A) <> '', 'Actif', 'Inactif')
      Else
            AuditLien = 'Web'
      End If
End Function

Cordialement,

Message édité par: myDearFriend!, à: 16/11/2005 23:49

 

[myDearFriend!]

Ci-joint le fichier...
[file name=mDF_AuditLiensHypertextes_20051116235045.zip size=29491]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/mDF_AuditLiensHypertextes_20051116235045.zip[/file]

 

[Jeanlebleu]

Salut le fil, Salut Mein Lieber Freund !

désolé de ne pas avoir répondu plus tôt, le boulot :angry: ...

J'ai quand même trouvé le temps de faire un petit bout de macro qui répond en gros à mon besoin (cf. exemple ci-joint).

A te lire, MDF, je crois que ta macro procède du même principe, mais en plus abouti B) je sens que je vais apprendre en comparant

Merci à toi MDF ! [file name=exemple_20051127003046.zip size=5381]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/exemple_20051127003046.zip[/file]