Makro korrigieren erweitern
mapa
In einer grossen Excel-Arbeitsmappe werden - verteilt über unzählige Tabellenblätter und verschiedene Spalten und Zellen - diverse
Hyperlinks (diese führen teils auf Lokale Dateien, teils auf Dateien im Intranet oder Internet) gesammelt und abgelegt.
Mittels folgendem Code (diesen habe ich mal vor langer Zeit hier im Forum angeboten erhalten) prüfe ich sporadisch, ob die in der
Datenbank enthaltenen Links auch wirklich noch existieren:
====================================================================================================
Option Explicit
Private Const FIFC = &H1
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" _
(ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Sub CommandButton1_Click()
Dim ausgabe As Workbook, ws As Worksheet, tb As Worksheet
Dim objHL As Hyperlink, zeile As Long
zeile = 2
Set ausgabe = Workbooks.Add
Set ws = ausgabe.Sheets(1)
With ws
.Cells(1, 1) = "Tabellenblatt"
.Cells(1, 2) = "Zellenadresse"
.Cells(1, 3) = "Hyperlink"
.Cells(1, 4) = "Hyperlinkadresse"
.Cells(1, 5) = "Status"
End With
With ThisWorkbook
For Each tb In .Sheets
For Each objHL In tb.Hyperlinks
ws.Cells(zeile, 1) = tb.Name
ws.Cells(zeile, 2) = objHL.Range.Address(0, 0)
ws.Cells(zeile, 3) = objHL.TextToDisplay
ws.Cells(zeile, 4) = objHL.Address
If InternetCheckConnection(objHL.Address, FIFC, 0&) = 0 Then
If objHL.Address "" Then
ws.Cells(zeile, 5) = "Fehlerhaft"
End If
Else
ws.Cells(zeile, 5) = "OK"
End If
zeile = zeile + 1
Next
Next
End With
ws.Columns.AutoFit
ausgabe.Activate
'Formatieren der Ausgabe-Liste:
ws.Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
ws.Columns("C:C").Select
Selection.ColumnWidth = 120
ws.Cells.Select
ws.Range("C1").Activate
Selection.AutoFilter
ws.Range("C11").Select
ActiveWindow.SmallScroll ToRight:=4
Selection.AutoFilter Field:=5, Criteria1:="Fehlerhaft"
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Fehlerhafte Hyperlinks in der Wissensdatenbank SC SW"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = "Stand: &D"
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With
ws.Range("A1").Select
End Sub
===================================================================================================================dieses Makro läuft an sich gut doch .
es scheint, als ob das Makro bloss die Schreibweise der Links prüft.
Beispiel: gibt es in der Datenbank einen Hyperlink www.googletest.com so wird der als korrekt ausgewiesen, obwohl es diese Seite gar nicht gibt.
Wie könnte / müsste ich mein obiges Makro anpassen, damit wirklich nicht bloss die syntax und Schreibweise eines Links, sondern auch deren wirklichen
Existenz geprüft wird ?
Im Voraus herzlichen Dank für Eure Hilfe und Tips !