Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1168to1172
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro korrigieren erweitern

Makro korrigieren erweitern
mapa
Guten Tag zusammen !
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 !

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Makro korrigieren erweitern
10.08.2010 12:00:57
MichaV
Hallo,
Füge vor dem ersten Private Sub diese Zeilen ein:

Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Private Type QOCINFO
dwSize As Long
dwFlags As Long
dwInSpeed As Long 'in bytes/second
dwOutSpeed As Long 'in bytes/second
End Type
Private Declare Function IsDestinationReachable Lib "SENSAPI.DLL" Alias " _
IsDestinationReachableA" (ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long

Dann ersetze die Zeile
If InternetCheckConnection(objHL.Address, FIFC, 0&) = 0 Then
durch diese 3 Zeilen:

Dim Ret As QOCINFO
Ret.dwSize = Len(Ret)
If IsDestinationReachable(objHL.Address, Ret) = 0 Then
Die Dim-Anweisung kannst Du natürlich auch ganz oben in die Sub schreiben.
Damit kannst Du allerdings nur abfragen ob ein Host existiert, also z.B. www.googletest.com. Ob einzelne Webseiten auf einem existierenden Host vorhanden sind kannst Du nicht abfragen. Die Seiten www.spiegel.de/blah.html oder www.google.de/blah.htm existieren nicht, es wird aber vom Server eine Fehlerseite erstellt, die die nicht-existierende Seite ersetzt. Du kannst den Unterschied zwischen automatisch erstellter Fehlerseite und "ordentlicher" Seite nicht abfragen.
Gruss- Micha
PS: hab ich aus http://forums.devshed.com/showpost.php?p=1727778&postcount=10
Anzeige
AW: Makro korrigieren erweitern
10.08.2010 13:06:14
mapa
Hallo
vorerst mal vielen dank für die tollen tips. Ich werde mir das gleich mal ausprobieren und dann über die Ergebnisse posten hier.
AW: Makro korrigieren erweitern
10.08.2010 13:18:34
mapa
also ... habs versucht aber .... ES GEHT NICHT :-(
Bei mir werden folgende Zeilen rot ausgeleuchtet:
Private Declare Function IsDestinationReachable Lib "SENSAPI.DLL" Alias " _
IsDestinationReachableA" (ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long
Da muss sich wohl irgendwo ein Fehler eingeschlichen haben ?
mein Code sieht nun so aus:
Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Private Type QOCINFO
dwSize As Long
dwFlags As Long
dwInSpeed As Long 'in bytes/second
dwOutSpeed As Long 'in bytes/second
End Type
Private Declare Function IsDestinationReachable Lib "SENSAPI.DLL" Alias " _
IsDestinationReachableA" (ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) 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
Dim Ret As QOCINFO
Ret.dwSize = Len(Ret)
If IsDestinationReachable(objHL.Address, Ret) = 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

Anzeige
AW: Makro korrigieren erweitern
10.08.2010 13:27:42
MichaV
schreib das mal in eine Zeile, also ohne den Unterstrich _ und den Umbruch danach:
Private Declare Function IsDestinationReachable Lib "SENSAPI.DLL" Alias "IsDestinationReachableA" (ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long
AW: Makro korrigieren erweitern
10.08.2010 13:36:35
mapa
ich probiers gleich mal aus !
AW: Makro korrigieren erweitern
10.08.2010 13:54:37
mapa
also....
makro läuft nun zwar, aber nun werden mir plötzlich unzählige seiten (welche mein makro vorher als korrekte seiten ausgewiesen hat) als fehlerhaft ausgewiesen, obwohl es sowohl den host, als auch die seite selber gibt.
irgendwie funzt das prüfen so nicht ganz
AW: Makro korrigieren erweitern
10.08.2010 14:07:34
MichaV
welche Seiten denn z.B.?
Anzeige
AW: Makro korrigieren erweitern
10.08.2010 14:19:30
MichaV
(ich hab wohl vergessen zu sagen dass Du nur auf hosts abfragen kannst. Denn auf Seiten abfragen geht sowieso nicht, siehe 1. Antwort)
AW: Makro korrigieren erweitern
10.08.2010 16:06:28
mapa
OK, verstehe !
aber danke dennoch herzlich für die top-Hilfe !!!
Danke für die Rückmeldung, owT
10.08.2010 17:51:11
MichaV

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige