Contrôler validité d'un lien hypertext avec VBA

Bonjour,

Voici un message déjà émis par Laurent Longre sur le sujet :

La procédure fait la vérification des liens situés dans la colonne A1:Ax,
Tu devras adapter selon tes besoins.

'=============================================== J'ai dans Excel une liste d'URL dans une colonne du type http://www.yahoo.fr Je
voudrais les tester pour contrôler si elles sont valides.
Une petite macro qui se contente de mettre en colonne B "OK" ou "Erreur" selon
que les URL en colonne A correspondent à des pages actuellement accessible ou
non. Et "Redirection vers..." si la page est automatiquement redirigée vers
une autre URL.
'------------------------------------------
'Déclaration des API dans le haut d'un module standard
Private Declare Function InternetOpenA Lib "Wininet" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, _
ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "Wininet" _
(ByVal hInternet As Long) As Long

Private Declare Function InternetOpenUrlA Lib "Wininet" _
(ByVal hInternet As Long, ByVal lpszUrl As String, _
ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Private Declare Function InternetQueryOptionA Lib "Wininet" _
(ByVal hInternet As Long, ByVal dwOption As Long, _
ByVal lpBuffer As String, lpdwBufferLength As Long) As Long
'------------------------------------------

sub Test()
Dim hInt As Long, hInt2 As Long, Cell As Range
Dim Buffer As String, dwBufferLength As Long
hInt = InternetOpenA("Excel", 0, vbNullString, vbNullString, &H200000)
With Range("A1", [A1].End(xlDown))
.Offset(0, 1).Clear
For Each Cell In .Cells
Cell(, 2).Select
hInt2 = InternetOpenUrlA(hInt, Cell, vbNullString, 0, 0, 0)
If hInt2 Then
dwBufferLength = 0
InternetQueryOptionA hInt2, 34, vbNullString, dwBufferLength
Buffer = Space$(dwBufferLength - 1)
InternetQueryOptionA hInt2, 34, Buffer, dwBufferLength
If Buffer = Cell Or Buffer = Cell & "/" Then _
ActiveCell = "OK" Else ActiveCell = "Redirigé vers " & Buffer
InternetCloseHandle hInt2
Else: ActiveCell = "Erreur"
End If
Next Cell
.Columns(2).AutoFit
End With
InternetCloseHandle hInt
end sub

Attention, une URL marquée "Erreur" ne correspond pas forcément à une
page inexistante. L'erreur peut être due à un serveur temporairement défaillant.
De même, une URL "OK" ne correspond pas forcément à une page réellement
existante, mais peut résulter d'une page d'erreur "404 Not Found". Donc rien
ne vaut les vérifications "manuelles"!
'===============================================


MichD
------------------------------------------
"Emile63" a écrit dans le message de groupe de discussion :
d9d73dc1-85c0-4693-a034-4ed6f25df3c2@i23g2000yqm.googlegroups.com...

Bonjour à tous,
A l'aide d'une procédure obtenue ici même par votre aide, je liste sur
un onglet tous les liens qui se trouvent sur une feuille de calcul (et
il y en a beaucoup).
J'aimerais savoir comment je peux l'améliorer en indiquant sur une
colonne supplémentaire les liens qui ne serraient plus valides ou
cassés.
Merci d'avance pour votre aide.

Cordialement,
Emile

-----------
If N > 0 Then
For i = N To 1 Step -1
If InStr(Z.Hyperlinks(i).Address, "@") = 0 Then
Cells(MaColonne, 1) = Z.Hyperlinks(i).Name
Cells(MaColonne, 2) = Z.Hyperlinks(i).ScreenTip
Cells(MaColonne, 3) = Z.Hyperlinks(i).Address()
Cells(MaColonne, 4) = Z.Hyperlinks(i).Parent.Address
MaColonne= MaColonne+ 1
End If
Next i
End If
---------

On 4 oct, 13:15, Emile63 wrote:
Bonjour MichD,

Merci pour ton aide et ta suggestion. je l'ai testée mais ce n'est pas
vraiment ce que je recherche.
Il faut dire, qu'à la base, mon explication n'étais pas complète. Je
vais préciser et m'expliquer:
Sur env. 400 liens hypertexte que compte ma feuille, seul 75
correspondent a des sites internet (www.xxxxxx.com).
Tous les autres pointent vers différents fichiers (xls, doc, mais
surtout pdf) qui se trouvent sur les disques du réseau.
Ces fichiers sont parfois déplacés ou effacés, et c'est ce qui me
pousse à cette vérification de l'hyperlien.
Au fond, je cherche a contrôler si le lien vers lequel pointe
l'hyperlien (je ne sais pas si c'est très clair ainsi exprimé ) est
toujours actif.

L'idée (qui ne fonctionne pas pour l'instant) c'est d'utiliser le
retour d'erreur:
If Z.Hyperlinks(i).Follow NewWindow:=False =vbNullString
then
Cells(MaColonne, 5) = "Erreur de lien"
Else: Cells(MaColonne, 5) =" Lien Ok"
End if

J'espère que c'est la bonne approche.. Si tu as une idée n'hésite pa s
à m'en faire part.

Très cordialement,
emile

-----------
    If N > 0 Then
        For i = N To 1 Step -1
            If InStr(Z.Hyperlinks(i).Address, "@") = 0 Then
                Cells(MaColonne, 1) = Z.Hyperlinks(i).N ame
                Cells(MaColonne, 2) = Z.Hyperlinks(i).S creenTip
                Cells(MaColonne, 3) = Z.Hyperlinks(i).A ddress()
                Cells(MaColonne, 4) = Z.Hyperlinks(i).P arent.Address

ICI, je verrai bien mon retour d'erreur.... :-))

                MaColonne= MaColonne+ 1
            End If
        Next i
    End If
---------

Comme ceci :
Dans la procédure "Test", Range("A1") contient un lien hypertexte. La fonction EstValide() retourne Vrai si l'adresse du lien
retourne un fichier valide sur le réseau (je n'ai pas vraiment testé, je ne travaille pas en réseau) ou un lien internet (la
procédure ne vérifie pas si le lien internet est valide ou non, sinon, il faut intégrer la fonction de Laurent Longre du
message précédent. La fonction retourne faux si l'adresse du lien ne correspond à aucune des 2 possibilités.

'------------------------------
Sub test()
MsgBox EstValide(Range("A1").Hyperlinks(1))
End Sub
'------------------------------

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


MichD
------------------------------------------
"Emile63" a écrit dans le message de groupe de discussion :
a0ba01b1-21de-4e01-87f8-29c170e44836@j31g2000vbl.googlegroups.com...

On 4 oct, 13:15, Emile63 wrote:
Bonjour MichD,

Merci pour ton aide et ta suggestion. je l'ai testée mais ce n'est pas
vraiment ce que je recherche.
Il faut dire, qu'à la base, mon explication n'étais pas complète. Je
vais préciser et m'expliquer:
Sur env. 400 liens hypertexte que compte ma feuille, seul 75
correspondent a des sites internet (www.xxxxxx.com).
Tous les autres pointent vers différents fichiers (xls, doc, mais
surtout pdf) qui se trouvent sur les disques du réseau.
Ces fichiers sont parfois déplacés ou effacés, et c'est ce qui me
pousse à cette vérification de l'hyperlien.
Au fond, je cherche a contrôler si le lien vers lequel pointe
l'hyperlien (je ne sais pas si c'est très clair ainsi exprimé ) est
toujours actif.

L'idée (qui ne fonctionne pas pour l'instant) c'est d'utiliser le
retour d'erreur:
If Z.Hyperlinks(i).Follow NewWindow:úlse =vbNullString
then
Cells(MaColonne, 5) = "Erreur de lien"
Else: Cells(MaColonne, 5) =" Lien Ok"
End if

J'espère que c'est la bonne approche.. Si tu as une idée n'hésite pas
à m'en faire part.

Très cordialement,
emile

-----------
If N > 0 Then
For i = N To 1 Step -1
If InStr(Z.Hyperlinks(i).Address, "@") = 0 Then
Cells(MaColonne, 1) = Z.Hyperlinks(i).Name
Cells(MaColonne, 2) = Z.Hyperlinks(i).ScreenTip
Cells(MaColonne, 3) = Z.Hyperlinks(i).Address()
Cells(MaColonne, 4) = Z.Hyperlinks(i).Parent.Address

ICI, je verrai bien mon retour d'erreur.... :-))

MaColonne= MaColonne+ 1
End If
Next i
End If
---------

On 4 oct, 13:15, Emile63 <...@gmail.com> wrote:

Bonjour MichD,

Merci pour ton aide,
j'ai trouvé mon bonheur, en assemblant un peu des deux
propositions... ;-)
Cordialement,
Emile