Lien sur fichier

Le 18/09/20 à 06:32, Brat'ac a écrit :

Bonjour,

Dans un classeur j'ai sur le texte de plusieurs cellules un lien qui
ouvre un PDF

J'essaie de faire en sorte que si le fichier n'est pas présent le lien
soit inopérant,
par exemple si mon fichier Excel est sur une autre machine et que
celle-ci n'ai pas le fichier
ou que le repertoire n'existe pas (sans message d'erreur si possible)
Possible ?
Merci de l'aide

Bonjour,

Dans le ThisWorkbook de ton classeur, copie ce qui suit.
Attention : Pour que cela fonctionne, l'exécution des macros
doit être activée à l'ouverture du fichier.

Le principe est d'ajouter le préfixe "ZKP-" au moment de désactiver
les liens hypertextes afin de pouvoir les reconnaître et d'activer
à nouveau les liens hypertextes le cas échéant.

'------------------------------------------------------
Private Sub Workbook_Open()

Call ThisWorkbook.Activer_Hypertexte
Call ThisWorkbook.Désactiver_Hypertexte

End Sub
'------------------------------------------------------
Sub Désactiver_Hypertexte()
Dim X As String, Sh As Worksheet
Dim H As Hyperlink, Adr As String
For Each Sh In ThisWorkbook.Worksheets
For Each H In Sh.Hyperlinks
With H
Adr = H.Parent.Value
If Dir(Adr) = "" Then
.Parent.Value = "ZKP-" & Adr
.Delete
End If
End With
Next
Next
End Sub
'------------------------------------------------------
Sub Activer_Hypertexte()
Dim Rg As Range, Adr As String, V As String
Dim Sh As Worksheet, Trouve As Range

For Each Sh In Worksheets
Set Rg = Sh.UsedRange
With Rg
Set Trouve = .Find(What:="ZKP-", _
LookIn:=xlValues, LookAt:=xlPart)

If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
Trouve.Replace What:="ZKP-", _
replacement:="", LookAt:=xlPart
Trouve.Hyperlinks.Add Anchor:=Trouve, _
Address:=V
Set Trouve = .FindNext(Trouve)
Loop Until Trouve Is Nothing
End If
End With
Next

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

MichD

Ce sont les mêmes macros que la précédente mais au lieu
d'ajouter le préfixe "ZKP-" au lieu hypertexte, on ajoute
3 espaces insécables (chr(160)) comme suffixe au lien hypertexte
afin de les reconnaître le cas échéant.

La seule différence, ces caractères ne sont pas visibles à l'oeil.


'--------------------------------------
Private Sub Workbook_Open()

Call ThisWorkbook.Activer_Hypertexte
Call ThisWorkbook.Désactiver_Hypertexte

End Sub
'--------------------------------------
Sub Désactiver_Hypertexte()
Dim X As String, Sh As Worksheet
Dim H As Hyperlink, Adr As String
Dim K As String
K = Chr(160) & Chr(160) & Chr(160)

For Each Sh In ThisWorkbook.Worksheets
For Each H In Sh.Hyperlinks
With H
Adr = H.Parent.Value
If Dir(Adr) = "" Then
.Parent.Value = Adr & K
.Delete
End If
End With
Next
Next
End Sub
'--------------------------------------
Sub Activer_Hypertexte()
Dim Rg As Range, Adr As String, V As String
Dim Sh As Worksheet, Trouve As Range
Dim K As String

K = Chr(160) & Chr(160) & Chr(160)
For Each Sh In Worksheets
Set Rg = Sh.UsedRange
With Rg
Set Trouve = .Find(What:=K, _
LookIn:=xlValues, LookAt:=xlPart)

If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
Trouve.Replace What:=K, _
replacement:="", LookAt:=xlPart
Trouve.Hyperlinks.Add Anchor:=Trouve, Address:=V
Set Trouve = .FindNext(Trouve)
Loop Until Trouve Is Nothing
End If
End With
Next

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

MichD

On peut aussi procéder sans ajouter de suffixe ou préfixe.
Pour retrouver les liens hypertextes, il s'agit alors
d'utiliser la séquence de caractères ":" déjà contenue
dans le l'adresse du lien hypertexte des cellules.

Chacune des macros ont des limites, dans le cas des suffixes et
préfixes, un usager pourrait les supprimer... et dans le cas
présent, certaines cellules pourraient contenir des adresses
sans qu'elles ne soient des liens hypertextes. À toi de choisir.

Les macros iraient comme suit :

'--------------------------------------------------------
Private Sub Workbook_Open()

Call ThisWorkbook.Activer_Hypertexte
Call ThisWorkbook.Désactiver_Hypertexte

End Sub
'--------------------------------------------------------
Sub Désactiver_Hypertexte()
Dim X As String, Sh As Worksheet
Dim H As Hyperlink, Adr As String

For Each Sh In ThisWorkbook.Worksheets
For Each H In Sh.Hyperlinks
With H
Adr = H.Parent.Value
If Dir(Adr) = "" Then
.Delete
End If
End With
Next
Next
End Sub
'--------------------------------------------------------
Sub Activer_Hypertexte()
Dim Rg As Range, Adr As String, V As String
Dim Sh As Worksheet, Trouve As Range
Dim K As String

K = ":"
For Each Sh In Worksheets
Set Rg = Sh.UsedRange
With Rg
Set Trouve = .Find(What:=K, _
LookIn:=xlValues, LookAt:=xlPart)

If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
Trouve.Hyperlinks.Add Anchor:=Trouve, Address:=V
Set Trouve = .FindNext(Trouve)
Loop Until Trouve.Address = Adr
End If
End With
Next

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

MichD

MichD a pensé très fort :

Merci pour toutes les explications , c'est parfait