Office: Weblinks mit VBA prüfen

TheDivision94 · 14. August 2016

Hallo Leute,

Ich habe in Excel eine Liste von Links zu Dokumenten auf einem firmeninternen Server. Diese Dokumente sind auf einem Share Point gespeichert werden aber auf diversen Seiten verlinkt. Durch neuere Versionen der Dokumente kann es passieren, dass ein Link nicht mehr richtig funktioniert, daher möchte ich gerne per VBA Abfrage meine URL-Liste überprüfen lassen und funktionsfähige Links in grün und kaputte Links rot einfärben.

Meine VBA-Kenntnisse sind stark eingerostet und habe mich durch das ganze Web gesucht und alles mögliche probiert.
Momentan ist der folgende Code in Verwendung. Jedoch funktioniert er nicht korrekt. Entweder werden alle Links als "ok" angezeigt, oder alle sind rot.
Auch nach verfälschen einiger zuvor "korrekter" Links zeigt mir das Makro die Links immer noch als okay an.
Jetzt gerade funktioniert es wieder nicht.
Zum Testen versuche ich "Google" aber selbst der Link ist angeblich defekt.

Habt ihr einen neuen Vorschlag?

Liebe Grüße

Code:

Sub Link_Pruefen()
Dim hypLink As Hyperlink
Dim varFehler As Variant
Dim AnzahlFalsch As Integer
Dim LetzteZeile As Integer
'Bestimmen der Letzten Zeile in Spalte B
LetzteZeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

ActiveSheet.Range(Cells(9, 2), Cells(LetzteZeile, 2)).Interior.ColorIndex = 0

For Each hypLink In ActiveSheet.Range(Cells(9, 2), Cells(LetzteZeile, 2)).Hyperlinks
If TypeName(hypLink.Parent) = "Range" Then
On Error Resume Next
varFehler = Dir(hypLink.Address)
If varFehler = "" Then
varFehler = Err.Number
Else
varFehler = Dir(hypLink.Address)
End If
On Error GoTo 0
If Not IsNumeric(varFehler) Then
hypLink.Parent.Interior.ColorIndex = 4
Else
hypLink.Parent.Interior.ColorIndex = 3
AnzahlFalsch = AnzahlFalsch + 1
End If
End If
Next
MsgBox AnzahlFalsch & " Verlinkungen sind fehlerhaft." & vbCrLf & vbCrLf & "Bitte beheben!", _
vbExclamation, "Defekte Links entdeckt!"
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

xlph · 16. August 2016

Dir() kann nur Pfade auf dem Rechner prüfen.

Code:

Public Sub Link_Pruefen()

Dim hypLink As Hyperlink
Dim lngLinkExternCount As Long
Dim lngLinkOkCount As Long
Dim lngLinkNotOkCount As Long
Dim lngLastRow As Long

With ActiveSheet

'Bestimmen der Letzten Zeile in Spalte B
lngLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row

With .Range(.Cells(9, 2), .Cells(lngLastRow, 2))

.Interior.ColorIndex = xlColorIndexNone

For Each hypLink In .Hyperlinks
hypLink.Parent.Select
Select Case LinkExist(hypLink.Address)
Case 0
hypLink.Parent.Interior.ColorIndex = 6 ' externer Link (mit Dir() nicht prüfbar)
lngLinkExternCount = lngLinkExternCount + 1
Case 1
hypLink.Parent.Interior.ColorIndex = 4 ' Link Ok
lngLinkOkCount = lngLinkOkCount + 1
Case 2
hypLink.Parent.Interior.ColorIndex = 3 ' Link nicht Ok
lngLinkNotOkCount = lngLinkNotOkCount + 1
End Select
Next

End With

End With

MsgBox "Links OK : " & vbTab & lngLinkOkCount & vbLf & _
"Links NOT OK : " & vbTab & lngLinkNotOkCount & vbLf & _
"Links Extern : " & vbTab & lngLinkExternCount _
, vbInformation, "Links"

End Sub

Private Function LinkExist(ByVal strLinkAddress As String) As Byte
On Error Resume Next
LinkExist = IIf(Dir(strLinkAddress, IIf(InStr(Right(strLinkAddress, 5), ".") > 0, vbNormal, vbDirectory)) = "", 2, 1)
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

TheDivision94 · 16. August 2016

Also kann ich externe Links garnicht testen?

Und danke für den Code, der arbeitet super.

xlph · 16. August 2016

Nicht mit Dir() aber mit einer Webabfrage.

Code:

Public Sub Hyperlink_Pruefen()

Dim hypLink As Hyperlink
Dim lngLinkOkCount As Long
Dim lngLinkNotOkCount As Long
Dim lngLastRow As Long

With ActiveSheet

'Bestimmen der Letzten Zeile in Spalte B
lngLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row

With .Range(.Cells(9, 2), .Cells(lngLastRow, 2))

.Interior.ColorIndex = xlColorIndexNone

For Each hypLink In .Hyperlinks

'hypLink.Parent.Select

Select Case LinkExist(hypLink.Address)
Case 0
hypLink.Parent.Interior.ColorIndex = 3 ' Link nicht Ok
lngLinkNotOkCount = lngLinkNotOkCount + 1
Case 1
hypLink.Parent.Interior.ColorIndex = 4 ' Link Ok
lngLinkOkCount = lngLinkOkCount + 1
End Select
Next

End With

End With

MsgBox "Links OK : " & vbTab & lngLinkOkCount & vbLf & _
"Links NOT OK : " & vbTab & lngLinkNotOkCount _
, vbInformation, "Links"

End Sub

Private Function LinkExist(ByVal strLinkAddress As String) As Byte

Dim strURL As String
Dim objWinHttpReq As Object

On Error Resume Next

LinkExist = Abs(Dir(strLinkAddress, IIf(InStr(Right(strLinkAddress, 5), ".") > 0, vbNormal, vbDirectory)) "")

If Err.Number > 0 Then

Set objWinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

strURL = strLinkAddress

objWinHttpReq.Open "GET", strURL, False
objWinHttpReq.Send
objWinHttpReq.SetTimeouts 10000, 10000, 10000, 10000 ' => Abbruch nach max. 10 sec.

'Debug.Print objWinHttpReq.responseText

LinkExist = Abs(Len(objWinHttpReq.responseText) > 0)

Set objWinHttpReq = Nothing

End If

On Error GoTo 0

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

TheDivision94 · 16. August 2016

Hmm... klappt trotzdem irgendwie nicht.
Selbst Google wird als fehlerhaft angezeigt.

xlph · 17. August 2016

Bei mir wird es grün.

Luschi · 17. August 2016

Hallo,

bei mir wird's auch grün.

Gruß von Luschi
aus klein-Paris

Office: Weblinks mit VBA prüfen

Weblinks mit VBA prüfen

Weblinks mit VBA prüfen

Weblinks mit VBA prüfen

Weblinks mit VBA prüfen - Similar Threads - Weblinks VBA prüfen

VBA in einer Zeile zu lang

Listbox wird nicht breiter, Schriftgrösse ändert sich

Kontrollkästchen aktivieren ohne VBA - wenn KK1 angekreuzt dann KK2 auch

Per Hyperlink ausgeblendetes Blatt einblenden

Bilder über VBA Größe und DPI ändern für Webshop

VBA: Platzhalter ersetzen und evtl. leere Zeile einfügen

Verweis auf Weblink in Formel