Tester les liens hypertextes

Version imprimable

Bonjour,

je voudrais créer une macro qui vérifierai si les liens hypertexte contenus dans les cellules d'une colonne sont valides.

Une première macro ajoute les liens hypertextes aux cellules qui contiennent déjà du texte:
Code:

1 2 3 4 5 6 7 For j = 1 To n ch1 = Sheets("Liste films").Cells(8 + j, 9).Value ch2 = Sheets("Liste films").Cells(8 + j, 1).Value chlien = ch1 & ch2 Sheets("Liste films").Cells(8 + j, 1).Select Selection.Hyperlinks.Add Anchor:=Selection, Address:=chlien Next j
Pour contrôler les lien hypertextes je me suis servi du code donné sur cette page dans une autre macro en lui disant de colorer en rouge les cellules dont les liens hypertextes ne sont pas valides:
Code:

1 2 3 4 5 6 7 8 9 Sub check_hypertexte() For k = 1 To n If VerifHyperlink(Cells(8 + k, 1)) = False Then Sheets("Liste films").Cells(8 + k, 1).Interior.Color = vbRed End If Next k End Sub
Le souci est que lorsque j’exécute cette macro, elle me colore des cellules même si le lien hypertexte qu'elles contiennent fonctionne correctement.

En fait certains liens renvoient à des fichiers présents sur le PC et d'autre vers des fichiers présents sur un disque dur externe et je remarque que le problème a lieu pour les fichiers du PC.

D'ailleurs lorsque je fais clic droit sur une cellule rouge puis "modifier lien hypertexte", l'adresse du lien contient des "%20" à la place des espaces, ce qui n'est pas le cas des fichiers du disque dur.

Donc je me dis que l'erreur vient de là mais je ne vois pas comment résoudre le problème.

Pourriez-vous m'aider s'il vous plait?

Merci.

11/07/2013, 00h51
Docmarti

Le problème ne vient sûrement pas des %20 qui remplacent les espaces.
Car c'est la façon normale de représenter les espaces dans les URL.

Il faut chercher le problème ailleurs.

Merci Docmarti.

En fait j'ai fait le test avec des fichiers sans espaces, le problème reste le même.

En fait les cellules sont colorées en rouge des que les liens hypertextes perdent leur couleur bleu, donc a chaque fois que la feuille est modifiée, par exemple après l’exécution d'une autre macro.

J'ai donc créé une nouvelle fonction VerifHyperlink2 qui renvoi dans une cellule le résultat de "Dir(Cible)" utilisé dans la fonction VerifHyperlink qui teste la validité des liens hypertextes.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Function VerifHyperlink(Cellule As Range) As Boolean Dim Cible As String 'Vérifie si la cellule contient un lien hypertexte If Cellule.Hyperlinks.Count = 0 Then VerifHyperlink = False Exit Function End If 'Extrait l'adresse du lien Cible = Cellule.Hyperlinks(1).Address 'Vérifie si le fichier existe. '(Ne fonctionne pas pour les liens web). If Dir(Cible) <> "" And Cible <> "" Then VerifHyperlink = True Else VerifHyperlink = False End If End Function
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Function VerifHyperlink2(Cellule As Range) As String Dim Cible As String 'Vérifie si la cellule contient un lien hypertexte If Cellule.Hyperlinks.Count = 0 Then VerifHyperlink2 = False Exit Function End If 'Extrait l'adresse du lien Cible = Cellule.Hyperlinks(1).Address 'Vérifie si le fichier existe. '(Ne fonctionne pas pour les liens web). If Dir(Cible) <> "" And Cible <> "" Then VerifHyperlink2 = Dir(Cible) Else VerifHyperlink2 = Dir(Cible) End If End Function
Code:

1 2 3 4 5 6 7 8 For k = 1 To n If VerifHyperlink(Cells(1 + k, 1)) = False Then Sheets("Liste films").Cells(1 + k, 1).Interior.Color = vbRed Sheets("Liste films").Cells(1 + k, 4) = VerifHyperlink2(Cells(1 + k, 1)) Else Sheets("Liste films").Cells(1 + k, 4) = VerifHyperlink2(Cells(1 + k, 1)) End If Next k
Lorsque les liens sont encore en bleu soulignés, le test VerifHyperlink est positif (cellule non colorée en rouge) et la cellule contient le nom du fichier cible. Par contre quand les liens ne sont plus en bleus , le test VerifHyperlink est négatif (cellule colorée en rouge) et la cellule est vide, ce qui explique le résultat négatif de VerifHyperlink.

Donc le souci viendrait du fait que même si le lien hypertexte existe et est correcte, le résultat de "Dir(Cible)" est vide.

Maintenant je ne vois toujours pas comment remédier à ce problème.

11/07/2013, 03h25
Docmarti

Si les liens ne sont plus en bleu, c'est que les liens n'existent plus.

La réponse qui me vient, c'est pourquoi tu permets à cette macro de remplacer le contenu des cellules qui contiennent des liens hypertextes que tu sembles vouloir conserver. C'est au niveau de cette macro qu'il faut agir. Ou bien, si ce n'est pas possible, créer une nouvelle macro qui recrée les liens hypertextes.

Bonjour,
Si j'ai bien compris tes liens hypertextes font référence à des fichiers se trouvant sur un disque.
Il est donc inutile d'utiliser l'adresse du lien comme tu le fais dans cette instruction

Code:

Cible = Cellule.Hyperlinks(1).Address

un simple Cible = Cellule.Value ou Cible = Cellule (la propriété Value étant la propriété par défaut) suffit.
Ce test permet de visualiser que nous avons bien l'adresse complète.
Code:

1 2 3 4 5 Dim sht As Worksheet, rng As Range Set sht = ThisWorkbook.Worksheets("Feuil1") For Each rng In sht.Range("B3:B8") If Len(rng) Then Debug.Print Dir(rng.Hyperlinks(1).Address) Next
Pour tester l'existence d'un fichier nous pouvons utiliser une fonction
Code:

1 2 3 Function IsFileExist(FileName As String) As Boolean IsFileExist = (Dir(FileName) <> "") End Function
Donc pour colorer en rouge les liens non valides
Code:

1 2 3 4 5 6 7 8 9 10 11 Sub Test() Dim sht As Worksheet, rng As Range Set sht = ThisWorkbook.Worksheets("Feuil1") For Each rng In sht.Range("B3:B8") With rng If Len(.Value) Then If IsFileExist(.Value) Then .Interior.Color = vbWhite Else .Interior.Color = vbRed End If End With Next End Sub
Et si l'on veut s'affranchir de l'appel à la fonction IsFileExist, on remplace la ligne 7 par celle-ci

Code:

If (Dir(.Value) <> "") Then .Interior.Color = vbWhite Else .Interior.Color = vbRed

Citation:

Envoyé par Docmarti

Si les liens ne sont plus en bleu, c'est que les liens n'existent plus.

La réponse qui me vient, c'est pourquoi tu permets à cette macro de remplacer le contenu des cellules qui contiennent des liens hypertextes que tu sembles vouloir conserver. C'est au niveau de cette macro qu'il faut agir. Ou bien, si ce n'est pas possible, créer une nouvelle macro qui recrée les liens hypertextes.

Non c'est tout l'inverse, ce que je voudrais c'est ne plus toucher aux cellules qui contiennent un lien hypertexte et je voudrais éviter de devoir recréer a chaque fois les liens hypertexte pour un gain de temps. Effectivement si je test les liens, immédiatement après avoir créé les liens (donc sans exécuter d'autres macro entre temps) le test fonctionne correctement.

Merci Philippe Tulliez, j'ai testé les codes que tu m'as donné en les adaptant à mon problème:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Sub control() Dim sht As Worksheet, rng As Range Set sht = ThisWorkbook.Worksheets("Liste films") For Each rng In sht.Range("A2:A4") With rng If Len(.Value) Then If (Dir(.Value) <> "") Then .Interior.Color = vbWhite Else: .Interior.Color = vbRed End If End If End With Next End Sub
Code:

1 2 3 4 5 6 7 8 9 Sub visualiser() Dim sht As Worksheet, rng As Range Set sht = ThisWorkbook.Worksheets("Liste films") For Each rng In sht.Range("A2:A4") If Len(rng) Then Debug.Print Dir(rng.Hyperlinks(1).Address) Next End Sub
Mais le problème est le même, même les lien hypertextes valides sont colorés, et cette fois même si je recrée les liens juste avant. Et le test "visualiser" ne renvoi rien.

11/07/2013, 12h29
Philippe Tulliez

Bonjour,
C'est très curieux car je teste toujours les codes avant de les publier et chez moi cela s'est très bien déroulé.
Tes liens hypertextes sont bien des fichiers se trouvant sur ton disque dur ?
11/07/2013, 12h35
youbewt

1 pièce(s) jointe(s)

Oui absolument les fichiers sont sur le disque dur du PC.

Voila ma feuille Pièce jointe 122810.
11/07/2013, 12h45
Philippe Tulliez

Bonjour,
Au moment où j'allais te poser la question n'utiliserais-tu pas la fonction LIEN_HYPERTEXTE, je vois ton post qui me confirme à l'ouverture du fichier que c'est le cas.
Mon test a été fait avec le lien hypertexte (Clic droit sur la cellule)
Il faut donc attaquer le problème autrement.
Je teste et je reviens
11/07/2013, 12h59
Docmarti

Citation:

Envoyé par youbewt

Non c'est tout l'inverse, ce que je voudrais c'est ne plus toucher aux cellules qui contiennent un lien hypertexte et je voudrais éviter de devoir recréer a chaque fois les liens hypertexte pour un gain de temps. Effectivement si je test les liens, immédiatement après avoir créé les liens (donc sans exécuter d'autres macro entre temps) le test fonctionne correctement.

Donc il faut bien identifier la macro qui crée le problème et qui t'oblige à recréer les liens hypertextes. Et envoie-nous le code de cette macro qu'il faut modifier, améliorer, adapter à tes besoins.
11/07/2013, 13h19
Philippe Tulliez

Bonjour,
La confusion vient du fait que Youbewt utilise la fonction LIEN_HYPERTEXTE alors que tout laissait à penser d'après son test de validité de lien qu'il s'agissait du lien hypertexte qui se construit par le clic droit sur la cellule.
A la limite, il n'y a aucune raison de créer une macro pour remplir les arguments de la fonction.
Il suffit d'avoir deux colonnes contenant les arguments de la fonction et faire référence aux cellules de ces colonnes.
11/07/2013, 15h11
Docmarti

Non, selon moi, il n'utilise pas de fonction LIEN_HYPERTEXTE.
Par macro, il crée le lien dans la colonne 1 en utilisant le nom du fichier qui se trouve en colonne 1 et le chemin du fichier qui se trouve en colonne 9.

Le problème est que les liens sont détruits par une autre macro qui apporte des modifications ou des ajouts à la feuille. Une solution simple serait de recréer automatiquement les liens après les modifications apportées par cette macro.

Oui effectivement dans le fichier que j'ai mis j'ai utilisé la fonction LIEN_HYPERTEXT mais même avec la méthode "Selection.Hyperlinks.Add Anchor:=Selection, Address:=chlien" le problème est le même.

Voici mon code complet (il est un peu long):

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
Sub mise_a_jour()
 
 
 
If Sheets("Liste films").FilterMode = True Then
   ActiveSheet.ShowAllData
End If
 
 
 
i = 9
n = 0
While Sheets("Liste films").Cells(i, 1) <> ""
      n = n + 1
      i = i + 1
Wend
 
 
 
'tri par ordre alphabétique:
ActiveWorkbook.Worksheets("Liste films").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Liste films").Sort.SortFields.Add Key:=Range("A4"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Liste films").Sort
     .SetRange Range(Cells(9, 1), Cells(8 + n, 25))
     .Header = xlNo
     .MatchCase = False
     .Orientation = xlTopToBottom
     .SortMethod = xlPinYin
     .Apply
End With
 
 
 
Sheets("Liste films").Cells(2, 14) = Application.WorksheetFunction.Sum(Range(Cells(9, 7), Cells(8 + n, 7))) / 1000 'taille en Go
Sheets("Liste films").Cells(3, 14) = n 'nombre de films
 
 
 
Sheets("Liste films").Range(Cells(9, 1), Cells(8 + n, 1)).Interior.TintAndShade = 0
 
'repérage des doublons:
d = 0
For i = 9 To 8 + n - 1
    If Sheets("Liste films").Cells(i, 1) = Sheets("Liste films").Cells(i + 1, 1) Then
       Sheets("Liste films").Cells(i, 1).Interior.Color = vbGreen
       Sheets("Liste films").Cells(i + 1, 1).Interior.Color = vbGreen
       d = d + 1
    End If
Next i
Sheets("Liste films").Cells(4, 14) = d 'nombre de doublons
 
 
 
Call generation_liens_hypertexte
 
 
 
Call check_hypertexte2
 
 
 
'détection films sans lien hypertexte:
h = 0
For i = 1 To n
    If Sheets("Liste films").Cells(8 + i, 1).Hyperlinks.Count = 0 Then
       Sheets("Liste films").Cells(8 + i, 1).Interior.Color = -4165632
       h = h + 1
    End If
Next i
If h <> 0 Then
   Sheets("Liste films").Cells(6, 12) = "Films sans lien hypertexte:"
   Sheets("Liste films").Cells(6, 14) = h
Else
   Sheets("Liste films").Range(Cells(6, 12), Cells(6, 14)).ClearContents
End If
 
end sub
 
 
 
Sub generation_liens_hypertexte()
 
 
i = 9
n = 0
While Sheets("Liste films").Cells(i, 1) <> ""
      n = n + 1
      i = i + 1
Wend
 
 
 
'Génération des liens hypertexte:
For j = 1 To n
 
    col1 = Sheets("Liste films").Cells(8 + j, 1)
    col2 = Sheets("Liste films").Cells(8 + j, 2)
    col3 = Sheets("Liste films").Cells(8 + j, 3)
    col6 = Sheets("Liste films").Cells(8 + j, 6)
    col8 = Sheets("Liste films").Cells(8 + j, 8)
    col9 = Sheets("Liste films").Cells(8 + j, 9)
    col23 = Sheets("Liste films").Cells(8 + j, 23)
    col25 = Sheets("Liste films").Cells(8 + j, 25)
 
    'construction et ajout du lien hypertexte:
    If col9 <> "Catégorie à préciser" Then
 
       If col8 = "Disque dur" Then
          ch0 = "H:\Films\"
          ch1 = Sheets("Liste films").Cells(8 + j, 9)
       ElseIf col8 = "PC" Then
          ch0 = "D:\Films\"
          ch1 = ""
       End If
 
       ch2 = Sheets("Liste films").Cells(8 + j, 1)
       ch3 = Sheets("Liste films").Cells(8 + j, 23)
 
       If col6 = "AVI" Then
          ch4 = ".avi"
       ElseIf col6 = "MKV" Or col6 = "MKV/Corp" Then
          ch4 = ".mkv"
       End If
 
       chlien = ch0 & ch1 & "\" & ch2 & " - " & ch3 & ch4
       Sheets("Liste films").Cells(8 + j, 25) = chlien
       Sheets("Liste films").Cells(8 + j, 1).Select
       Selection.Hyperlinks.Add Anchor:=Selection, Address:=chlien
 
    End If
 
Next j
 
 
End Sub
 
 
 
Sub check_hypertexte2()
 
i = 9
n = 0
While Sheets("Liste films").Cells(i, 1) <> ""
      n = n + 1
      i = i + 1
Wend
 
 
 
Dim sht As Worksheet, rng As Range
 Set sht = ThisWorkbook.Worksheets("Liste films")
 For Each rng In sht.Range("A9:A300")
  With rng
   If Len(.Value) Then
    If IsFileExist(.Value) Then .Interior.Color = vbWhite Else .Interior.Color = vbRed
   End If
  End With
 Next
 
 
End Sub
 
 
 
 
 
Function IsFileExist(FileName As String) As Boolean
 IsFileExist = (Dir(FileName) <> "")
End Function

Le code suivant fonctionne chez moi :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub control()
On Error GoTo GestionDerreurs
 
'Range("A2:B4").ClearFormats 'Supprime la couleur bleu
 
Dim sht As Worksheet, rng As Range
Set sht = ThisWorkbook.Worksheets("Liste films")
 
DerniereLigneEnA = sht.Range("A:A").Find("*", , LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
For Each rng In sht.Range("A2:A" & DerniereLigneEnA)
 
    With rng
     If rng.Hyperlinks.Count > 0 Then
      'If Dir(rng.Hyperlinks(1).Address) Then
      If Dir(rng.Hyperlinks(1).Address) <> "" Then
                .Interior.Color = vbWhite
            Else: .Interior.Color = vbRed
            End If
         End If
    End With
Next
  Exit Sub
 
GestionDerreurs:
  MsgBox "Erreur " & Err.Number & " - " & Error
 
End Sub

Ta façon de reconstituer le nom du fichier que tu obtiens par

ch2 & " - " & ch3 & ch4

sur la ligne

Code:

chlien = ch0 & ch1 & "\" & ch2 & " - " & ch3 & ch4

est complexe.

Pourrais-tu joindre un fichier avec quelques lignes de données ?

31/07/2013, 01h24
youbewt

Ca y est ça marche avec le code de Docmarti.

Merci pour votre aide.
31/07/2013, 15h14
Docmarti

Merci à toi pour ce retour.