Antwort zu "Hyperlink-Erreichbarkeit"
NoNet
vor einigen Tagen habe ich hier im Forum meine Frage gestellt :
https://www.herber.de/forum/messages/1084301.html
Und Rudi hat ja auch schonmal nachgefragt :
https://www.herber.de/forum/archiv/1084to1088/t1085232.htm#1085243
Da dieser Thread bereits einige Tage zurückliegt und daher kaum mehr beachtet werden dürfte, poste ich meine Antwort hier in einem neuen Beitrag.
Zu den abgegebenen Antworten : Ich habe alle Varianten angepasst und getestet, doch leider waren diese alle nicht erfolgreich. Dies liegt jedoch (hoffentlich ) nicht an meinen "mangelnden" VBA-Kenntnissen, sondern offenbar daran, dass der PING nicht durch unsere Firmenfirewall durchgereicht wird, was sich auch bei direktem "Anpingen" einer Webseite per "DOS-Box" (Eingabeaufforderung) darstellt :
Nach Rücksprache mit dem Kunden (habe ihn erst heute wieder erreicht) stellt es sich so dar, dass in seiner Mappe zahlreiche Links auf diverse Ziele enthalten sind, die er überprüfen möchte :
- Intranetseiten / Dateien im Intranet / Internetseiten / Dateien im Internet
- Lokal gespeicherte Dateien
- auf Netzlaufwerken gespeicherte Dateien
Diese Links befinden sich z.T. in Zellen (teils als Klartekt, teils auch mit anderem Text angezeigt), z.T. auch als Hyperlinks (kein VBA : FollowHyperlink !) in Objekten (hauptsächlich in Autoforms).
Für die Intra-/Internet-Seiten bzw. Dateien konnte ich bisher mangels PING-Möglichkeit noch keine Lösung finden, aber zumindest für die Hyperlinks in Zellen und Objekten habe ich nun eine recht universelle UDF programmiert. Mit dieser UDF kann man überprüfen, ob in Zellen oder in Objekten (deren linke obere Ecke in einer bestimmten Zelle liegt) ein gültiger Hyperlink zu lokal oder im Netz gespeicherten Dateien liegt. Nicht berücksichtigt sind SUB-Adressen (z.B. Links zu bestimmten Zellen in EXCEL-Mappen oder zu Lesezeichen in WORD-Dokumenten oder PDF-Dateien oder Folien in PPTs etc !).
Diese UDF möchte ich euch nicht vorenthalten, vielleicht kann sie ja auch jemand gebrauchen :
Option Explicit
Public Function HyperlinkOK(strLink, Optional bolObject) As Boolean
'UDF zum Überprüfen der Gültigkeit von Hyperlinks in Zellen oder Objekten aus Zelle
'Es werden nur Hyperlinks zu lokal oder auf Netzlaufwerk gespeicherten DATEIEN/ORDNER
'berücksichtigt, keine Hyperlinks auf INTERNET/INTRANET (kein http://
, _
ftp:// etc. !)
'und auch keine Hyperlinks innerhalb der gleichen Mappe (SUBADDRESS, z.B. Tabelle2!A1)
'Verwendung im Tabellenblatt :
'=HYPERLINKOK(A1) => prüft, ob Zelle A1 leer ist oder gültigen Hyperlink enthält
'=HYPERLINKOK(A1;1) => prüft, ob Objekt (z.B. Autoform) in A1 keinen oder gültigen _
Hyperlink enthält
'03.07.2009, NoNet - www.excelei.de (z.Zt. down !)
Application.Volatile 'Ergebnis soll sich bei Zelländerungen automatisch _
aktualisieren !
On Error Resume Next 'Fehler (z.B. Shape-Hyperlink-Zuweisung) ignorieren
Dim strTemp As String, strPfad As String
Dim intS As Integer, objShape As Shape
Dim shHyp As Hyperlink
Dim objFSO As Object
If IsMissing(bolObject) Then 'Zellinhalt prüfen (nicht Objekt aus Zelle _
prüfen)
If strLink.Hyperlinks.Count = 0 Then 'Hyperlink als Text in Zelle
strTemp = strLink 'Text aus Zelle zuweisen
Else '"echter" definierter Hyperlink in Zelle
strTemp = strLink.Hyperlinks(1).Address 'Hyperlink der Zelle zuweisen
End If
Else 'Wenn Objekt-Parameter angegeben wurde
If bolObject Then 'Wenn Objekt, nicht Zellinhalt, geprüft _
werden soll
For Each objShape In strLink.Parent.Shapes 'Alle Objekte/Shapes des Blattes _
durchlaufen
If objShape.TopLeftCell = strLink Then 'Wenn linke obere Ecke des Obj. in _
Zelle liegt
Set shHyp = objShape.Hyperlink
If Not shHyp Is Nothing Then
strTemp = objShape.Hyperlink.Address 'Hyperlink-Adresse aus Objekt
Exit For 'Vorzeitiger Abbruch der FOR EACH _
Schleife
End If
End If
Next
Else
If strLink.Hyperlinks.Count = 0 Then 'Hyperlink als Text in Zelle
strTemp = strLink 'Text aus Zelle zuweisen
Else '"echter" definierter Hyperlink in _
Zelle
strTemp = strLink.Hyperlinks(1).Address 'Hyperlink der Zelle zuweisen
End If
End If
End If
strTemp = Replace(strTemp, "/", "\") 'Slash in Backslah tauschen
strTemp = Replace(strTemp, "%20", " ") 'HTML-Zeichen %20 (= ASCII 32) in _
Leerzeichen tauschen
If Left(strTemp, 2) = "\\" Or Mid(strTemp, 2, 1) = ":" Then
strPfad = "" 'Link absolut angegeben
Else
strPfad = ActiveWorkbook.Path 'Link relativ zur aktuellen Mappe
End If
While Left(strTemp, 1) = "." 'Überprüfen, ob Pfad mit "." beginnt
If Left(strTemp, 3) = "..\" Then 'Überprüfen, ob Pfad mit "..\" beginnt => Ü _
bergeordnetes Verzeichnis
strPfad = Left(strPfad, Len(strPfad) - InStr(StrReverse(strPfad), "\")) 'Ü _
bergeordnet. Pfad
strTemp = Mid(strTemp, 4, Len(strTemp)) 'relativen Pfad um 1 Ebene kürzen
ElseIf Left(strTemp, 2) = ".\" Then 'Wenn gleiche Ebene (=> KEIN übergeordnet. _
Pfad !)
strTemp = Mid(strTemp, 3, Len(strTemp)) 'relativen Pfad um 1 Ebene kürzen
End If
Wend
Set objFSO = CreateObject("Scripting.FileSystemObject")
If strPfad = "" Then 'Wenn Pfad ABSOLUT angegeben wurde
HyperlinkOK = objFSO.FileExists(strTemp) Or _
objFSO.FolderExists(strTemp) 'Prüfen, ob Datei oder Ordner existiert (per _
FSO)
Else 'Wenn Pfad REALTIV angegeben wurde
HyperlinkOK = objFSO.FileExists(strPfad & "\" & strTemp) Or _
objFSO.FolderExists(strPfad & "\" & strTemp) 'Prüfen, ob Datei oder Ordner _
existiert
End If
'DIR()-Variante : berücksichtigt leider keine "Hidden"-Files und keine Links auf Ordner !!
' If strPfad = "" Then 'Wenn Pfad ABSOLUT angegeben wurde
' HyperlinkOK = Dir(strTemp) "" 'Prüfen, ob Datei existiert
' Else 'Wenn Pfad REALTIV angegeben wurde
' HyperlinkOK = Dir(strPfad & "\" & strTemp) "" 'Prüfen, ob Datei existiert
' End If
'STACK-Speicher für Objektvariablen in umgekehrter Reihenfolge wieder freigeben :
Set objFSO = Nothing
Set shHyp = Nothing
End Function
Vielleicht hat ja noch jemand eine Idee zur Überprüfung von Erreichbarkeit von Links auf Webseiten (möglichst ohne PING !) !?!?!?
Danke erstmal für die Mitarbeit, Gruß NoNet
PS : Schönes WE an alle....
