Per VBA : Erreichbarkeit von Hyperlinks überprüfen

ich habe eine Excel-Tabelle mit zahlreichen Hyperlinks ins WWW (diverse unterschiedliche URLs), _ _ z.B. : http://www.irgend-eine-seite. _ _ com/forum/Beitrag4711.php http://was-soll.das/? http://www.meinebank. _ _ ru/konto/nepper/schlepper/Bauernfaenger.asp http://www.abcxyz.de etc. Nun möchte ich per VBA überprüfen, welche URLs noch erreichbar sind und welche "tot" sind. Leider fehlt mir der passende Ansatz dazu :-( - könnte mir jemand einen Tip geben ? Was ich NICHT möchte : Hyperlink mit IE aufrufen und dann den Status des IE abfragen ! Der Code sollte browserunabhängig funktionieren (evtl. per API ?) und z.B. als FUNCTION einen _ _ Returncode zurückgeben. Zusätzliches Problem : Wenn ich z.B. http://www.irgend-eine-seite.com/forum/Beitrag4711.php abfrage, diese Seite jedoch nicht mehr erreichbar ist und der Server dann automatisch auf http://www.irgend-eine-seite.com/default404.html umleitet, wird zwar eine Seite angezeigt, aber nicht die zu überprüfende Seite - dieser Link _ sollte dann auch als "tot" gemeldet werden. Ich bin über jede konstruktive Hilfe dankbar, Gruß NoNet

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Function GetLinkStatus(ByVal strUrl As String) As Boolean Dim objXMLHTTP As Object If Not Left$(strUrl, 7) = "http://" Then strUrl = "http://" & strUrl Set objXMLHTTP = CreateObject("Msxml2.XMLHTTP") On Error Resume Next objXMLHTTP.Open "GET", strUrl, False objXMLHTTP.Send GetLinkStatus = objXMLHTTP.Status = 200 Set objXMLHTTP = Nothing On Error GoTo 0 End Function

Option Explicit ' nach: URLs testen - von Josef Ehrensberger am 01.02.2011 16:35:45 ' www.herber.de/forum/archiv/1196to1200/t1198467.htm#1198487 Sub CheckURL() Dim rngBer As Range, rngC As Range, objHttpReq As Object Set objHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1") Set rngBer = Cells(2, 4).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1) rngBer.Interior.Pattern = xlNone For Each rngC In Cells(2, 4).Resize( _ Cells(Rows.Count, 1).End(xlUp).Row - 1) If rngC.Text Like "htt" & "p://*" Then ' wegen Codedarstellung im Forum With objHttpReq .Open "GET", rngC.Text .Send If .StatusText "OK" Then rngC.Interior.Color = 255 ' rngC.Offset(0, 1) = .Status ' rngC.Offset(0, 2) = .StatusText End With End If Next rngC Set objHttpReq = Nothing End Sub

Hallo Erich,
ich habe gesehen, dass im Code nur die Adressen geprüft werden, wenn diese entweder "htt" oder "p://*" enthalten.
Zum Testen habe bei einigen Links, die mit "www" beginnen, vorne noch "http" eingetragen.
Meldung:
Laufzeitfehler '-2147012889 (80072ee7)':
Der Servername oder die Serveradresse konnte nicht verarbeitet werden !!
Wenn ich es nur mit Internetadressen teste, die auch erreichbar sind, dann kommt keine Meldung.
Diese kommt nur dann, wenn eine Internetadresse nicht erreichbar ist.
Vielleicht lässt sich diese Meldung abfangen.
Die Adressen, die nicht erreichbar sind, sollen mit rote Füllfarbe dargestellt werden.
Es wäre schön, wenn der Code auch mit Adressen funktionieren würde, die mit "www" beginnen.
Viele Grüße,
Selma

Hi Selma,
"dass im Code nur die Adressen geprüft werden, wenn diese entweder "htt" oder "p://*" enthalten" ?
Stimmt nicht so ganz. Da geht es nicht um entweder - oder.
Da steht "htt" & "p://*" im Code, und "&" ist der Verkettungsoperator, also steht da nur
h ttp://*
(ohne das Leerzeichen hinter dem h, das habe ich hier nur eingefügt wegen der Darstellung hier im Forum)
Nur wegen dieser Darstellung hatte ich auch "htt" & "p://*" geschrieben.
Richtig ist, dass der Code nur URLs prüft, die mit dem http-Text beginnen.
Die Beispiele in deinem Eingangsbeitrag fingen ja auch alle damit an.
Hier eine Version, die nötigenfalls das http voranstellt.
An drei Stellen steht statt "http" der Text "h ttp" im Code,
da musst du jeweils das Leerzeichen nach dem h löschen:


Sub CheckURL()
Dim rngBer As Range, rngC As Range, oHttpReq As Object, strT As String
Set oHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
Set rngBer = Cells(2, 4).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
rngBer.Interior.Pattern = xlNone
For Each rngC In Cells(2, 4).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
strT = rngC.Text
' falls nötig, vorn "h ttp://" ergänzen
If LCase$(Left$(strT, 7))  "h ttp://" Then strT = "h ttp://" & strT
With oHttpReq
.Open "GET", strT
.Send
If .StatusText  "OK" Then rngC.Interior.Color = 255
rngC.Offset(0, 1) = .Status                           ' zum Testen
rngC.Offset(0, 2) = .StatusText                       ' zum Testen
rngC.Offset(0, 3) = strT                              ' zum Testen
End With
Next rngC
Set oHttpReq = Nothing
End Sub

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Option Explicit Sub CheckURL2() Dim rngBer As Range, rngC As Range, oHttpReq As Object Dim strUrl As String, lngS As Long, strErg As String Set oHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1") Columns("E:G").ClearContents Set rngBer = Cells(2, 4).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1) rngBer.Interior.Pattern = xlNone On Error Resume Next For Each rngC In rngBer strUrl = rngC.Text ' falls nötig, vorn "h ttp://" ergänzen If LCase$(Left$(strUrl, 7)) "h ttp://" Then strUrl = "h ttp://" & strUrl lngS = 0 With oHttpReq .Open "GET", strUrl .Send lngS = .Status Select Case lngS Case 200: strErg = .StatusText Case 404: strErg = .StatusText rngC.Interior.Color = 255 Case Else: strErg = "Fehler" rngC.Interior.Color = 255 End Select rngC.Offset(0, 1) = lngS ' zum Testen rngC.Offset(0, 2) = strErg ' zum Testen rngC.Offset(0, 3) = strUrl ' zum Testen End With Next rngC On Error GoTo 0 Set oHttpReq = Nothing End Sub

Sub CheckURL2() Dim rngBer As Range, rngC As Range, oHttpReq As Object Dim sUrl As String, lngS As Long, strErg As String Set oHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1") Columns("E:G").ClearContents Set rngBer = Cells(2, 4).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1) rngBer.Interior.Pattern = xlNone On Error Resume Next With oHttpReq For Each rngC In rngBer sUrl = rngC.Text If Len(sUrl) > 4 Then ' mind. 5 Zeichen ' falls nötig, vorn "h ttp://" ergänzen If LCase$(Left$(sUrl, 7)) "h ttp://" Then sUrl = "h ttp://" & sUrl lngS = 0 .Open "GET", sUrl .Send lngS = .Status Select Case lngS Case 200: strErg = .StatusText Case 404: strErg = .StatusText rngC.Interior.Color = 255 Case Else: strErg = "Fehler" rngC.Interior.Color = 255 End Select rngC.Offset(0, 1) = lngS ' zum Testen rngC.Offset(0, 2) = strErg ' zum Testen rngC.Offset(0, 3) = sUrl ' zum Testen End If Next rngC End With On Error GoTo 0 Set oHttpReq = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Per VBA : Erreichbarkeit von Hyperlinks überprüfen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Per VBA : Erreichbarkeit von Hyperlinks überprüfen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread