VBA: Attribuer un hyperlien avec le contenu de la cellule

[Emile63]

Bonjour à tous,

J'ai des feuille excel servant à des faire de tests qui sont stockés dans un répertoire: "\Tests\
(dont j'extrais le nom et chemin complet dans un classeur récapitulatif séparé)
Puis quand le test est terminé, ces classeurs sont déplacés dans un répertoire: "\Tests terminés\"

Dans la classeur récapitulatif, J'aimerais bien attribuer le lien hypertexte à la cellule qui contient le chemin complet & nom de fichier de celui-ci.

Le problème c'est que si depuis la dernière fois, le classeur de test à été déplacé dans le répertoire test terminée, le lien en question ne fonctionnera plus.
Je souhaiterais donc contrôler d'abord si lien il y a, si non le créée selon son nom (de la cellule), et contrôler si ce lien est valide.
Si invalide, lui changer le nom de répertoire dans la cellule et re-créer un nouveau lien avec cette nouvelle adresse.

Je ne sais pas si je me suis fait comprendre (mais je l'espère), à tout hasard, je pose ci-après ce bout de code (très approximatif) autour de quoi je test.

Je vous remercie d'avance pour votre aide,
Cordialement.
Emile

------------------------------------
Sub Raffraichir_Hyperliens()
Dim strLien As String, Hpk As Hyperlink, x As Integer, I As Integer, I As Integer

N = Range("R4:R" & Rows.Count)
If N > 0 Then
For I = N To 1 Step -1

For Each C In Selection
If C.Hpk.Count = 1 Then GoTo Fin
ActiveSheet.Hpk.Add Anchor:=C, Address:=C.Value, TextToDisplay:="Ouvrir fichier"
If ActiveCell.VerifHyperlink = False Then
strLien = Hpk.Address
Hpk.Address = Replace(strLien, "\Tests\", "\Tests terminés\")
End If
Next C

If Cells(x, 1) = Empty Then Exit For

Next
Next I
End If
Fin:

End Sub
---------------------------------------

[MichD]

Bonjour,

Comme d'habitude, je n'ai rien compris à ta question.

Voici un petit exemple de code que tu devrais adapter toi-même à ta
problématique!

'------------------------------------------------
Sub TEST()
Dim H As Hyperlink, Adr As String, Chemin_Fichier As String
Dim Fichier As String, Chemin As String, C As Range
On Error Resume Next
'Variable pointant sur le lien hypertexte de la cellule A1

With Worksheets("Feuil1")
For Each C In .Range("A1:A10")
Set H = Range("A1").Hyperlinks(1)
If Err = 0 Then
'la cellule contient un lien hypertexte
'Obtenir le chemin du fichier
Chemin_Fichier = H.Address
'obtenir le nom du fichier
Fichier = Split(Chemin_Fichier,
"\")(UBound(Split(Chemin_Fichier, "\")))
'Isoler le chemin où se retrouve le fichier
Chemin = Replace(Chemin_Fichier, Fichier, "")
'Supprimer le lien hypertexte si besoin
H.Delete
'Créer un nouveau lien hypertexte au besoin
NouveauChemin = X 'insérer le nouveau chemin se terminant
par "\"
NouveauFichier = y 'insérer le nouveau nom du fichier au
besoin.
'Recréer le lien hypertexte
C.Hyperlinks.Add C, NouveauChemin & NouveauFichier
Else
'Que faire si la cellule ne contient pas un lien hypertexte
'Efface l'erreur
Err = 0
End If
Next
End With

End Sub
'------------------------------------------------

[Emile63]

Bonjour MichD,
Je te remercie pour ton aide et pour ta proposition.
Je reconnais que mon explication n'était pas facile a comprendre. Mais comme d'habitude, tu as vu juste.
Ton exemple de code m'a bien aidé. Voici l'exécution finale:
(Peut-être pourrait-elle être affinée pour s'exécuter plus rapidement)
-------------------------------------------------------
Sub AfficheLesLiensHypertexte()
'Insertions des hyperliens du contenu des cellules
Dim N As Integer, MonTest As Boolean
On Error Resume Next
For Each C In Range("R4", [R65000].End(xlUp))
N = C.Hyperlinks.Count
If N > 0 Then
MonTest = EstValide(C.Hyperlinks(1))
If MonTest Then
GoTo Suite
Else
Chemin_Fichier = C.Value

Fichier = Split(Chemin_Fichier, "\")(UBound(Split(Chemin_Fichier, "\")))

Chemin = Replace(Chemin_Fichier, Fichier, "")

NouveauChemin = "R:\Comparatifs terminés\"
C.Hyperlinks.Add C, NouveauChemin & Fichier, , "Ouvrir fichier", NouveauChemin & Fichier
End If
End If
If C.Value = "Ancien" Then Err = 0: GoTo Suite
C.Hyperlinks.Add Anchor:=C, Address:=C.Value, TextToDisplay:=C.Value, ScreenTip:="Ouvrir fichier"
If EstValide(C.Hyperlinks(1)) = False Then
Chemin_Fichier = C.Value

Fichier = Split(Chemin_Fichier, "\")(UBound(Split(Chemin_Fichier, "\")))

Chemin = Replace(Chemin_Fichier, Fichier, "")

NouveauChemin = "R:\Comparatifs terminés\"
C.Hyperlinks.Add C, NouveauChemin & Fichier, , "Ouvrir fichier", NouveauChemin & Fichier
End If
Suite:
Next
Range("R4").Select
Range("R4", Selection.End(xlDown)).Select
End Sub

Function EstValide(Lien As Hyperlink) As Boolean
On Error Resume Next
If Dir(Lien.Address) <> "" Then
If Err <> 0 Then
Err.Clear
If UCase(Left(Lien.Address, 4)) = "HTTP" Then
EstValide = True
Else
EstValide = False
End If
Else
EstValide = True
End If
End If
End Function
----------------------------------------

[Emile63]

Bonjour MichD,
La procédure qui fonctionnait bien hier ne fonctionne plus aujourd'hui... :-(

Je crois savoir d'ou vient le problème mais ne sais pas comment y remédier:

Quand le le chemin complet (qui se trouve dans une cellule) est converti en hyperlink, et tant que le fichier reste ouvert, ça fonctionne.
Si je ferme le fichier, et le ré-ouvre ultérieurement, alors l'adresse qui était alors dans l'hypertexte se modifie comme suit:
Avant: [ R:\Test\Tests 2015-00301 Tests, Machine.xlsm ] (Rép. en réseau)
Après: [ ../Test/Tests%2015-00301%20Tests,%20Machine.xlsm ]

Du coup la fonction en place pour assurer que le lien est toujours valide renvoie tout en "Err" sans doute due à ce que "Dir" n'identifie plus correctement le répertoire, chemin etc..:
----------------------------------------------

Function EstValide(Lien As Hyperlink) As Boolean
On Error Resume Next
If Dir(Lien.Address) <> "" Then
If Err <> 0 Then
Err.Clear
If UCase(Left(Lien.Address, 4)) = "HTTP" Then
EstValide = True
Else
EstValide = False
End If
Else
EstValide = True
End If
End If
End Function

---------------------------------------------

[MichD]

Ta version n'est plus installée sur mon ordinateur.

Ce que tu observes, c'est l'adresse absolue du fichier dans ton code,
est transformé en adresse relative. Par conséquent, le lien est valide,
mais lors d'un clic sur le lien, ce dernier n'arrive pas à trouver le
fichier.

Je ne peux pas être très précis dans ma réponse, mais à cette adresse tu
trouveras comme on doit s'y prendre pour Word 2003. Je suppose qu'Excel
doit se comporter de manière similaire...

https://support.microsoft.com/fr-fr/kb/903163

Lis aussi ceci sur la FAQ de Word, Excel doit être similaire!

http://www.faqword.com/index.php/word/faq-word/references/378-comment-mettre-en-absolu-un-lien-hypertexte

[Emile63]

Merci MichD pour cette piste.
Je teste l'une des 2 solutions de Microsoft pour convertir en adresse absolue, qui consiste depuis les propriétés avancées du document, onglet résumé, Répertoire Web : à taper un "x".

Et laisse la seconde en stand by, au cas ou ...
Application.DefaultWebOptions.UpdateLinksOnSave = False

Pour l'instant le "x" semble fonctionner :-)

Encore merci pour ton aide
cordialement,
Emile