Text in div. Webadressen finden

Sub CheckURL2_Schulungen() Sheets("Schulungen").Activate 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("J:L").ClearContents Set rngBer = Cells(2, 6).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, 4) = lngS ' zum Testen rngC.Offset(0, 5) = strErg ' zum Testen rngC.Offset(0, 6) = sUrl ' zum Testen End If Next rngC End With On Error GoTo 0 Set oHttpReq = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc] Private Declare PtrSafe Function FindWindowA Lib "user32" ( _ ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub CheckURL2_Schulungen() Dim iOk As Integer ' Dein Code lngS = .Status Do If FindWindowA("#32770", "SAP Meldung") <> 0 Or iOk > 10 Then Exit Do Sleep 100 iOk = iOk + 1 Loop If iOk > 9 Then Debug.Print "Seite ncht freigegeben!" Select Case lngS ' Dein Code End Sub

Moin Karl-Heinz
Moin Zwenn
erst einmal dankeschön fürs Antworten,
Hab das ganze mal ausprobiert, das Programm mit der Modifizierung, läuft ohne Debug durch,
hier beispielhaft die Reaktion auf die Web Adresse in Zeile 274 meiner Datenbank, hier wird der entsprechenden Text "Leider wurde diese Website nicht für Sie freigegeben." ausgewiesen mit der Web Adresse:
https://applications.bilfinger.net/p/addd7b1ac/VD/_layouts/15/AccessDenied.aspx?Source=https%3A%2F%2Fapplications%2Ebilfinger%2Enet%2Fp%2Faddd7b1ac%2FVD%2FVorgabedokumente%2FBAG%5F7332%5FS%5F005%5FDE%5FGruppe%20leichtentz%C3%BCndliche%20Gefahrstoffe%2Epdf&correlation=b92509a0%2D0abb%2D20ad%2D4a49%2D1d235a3a7ad0&Type=item&name=6c32438c%2D0269%2D4a86%2D9940%2Dd02e563bd83c&listItemId=10102
steht, also direkt im zurück gelieferten HTML-Dokument was hoffentlich die Frage von Zwenn beantwortet.
in Zelle A274 steht
BAG_7332_S_005_Gruppe leichtentzündliche Gefahrstoffe
in Zelle B274 steht
https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7332_S_005_DE_Gruppe%20leichtentz%C3%BCndliche%20Gefahrstoffe.pdf
in Zelle C274 bis E274 wird dabei vom Programm folgendes erzeugt
Zelle C274 =
200
Zelle D274 =
OK
Zelle E274 = https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7332_S_005_DE_Gruppe%20leichtentz%C3%BCndliche%20Gefahrstoffe.pdf
also alles so als wäre die Web Adresse noch existent, die Programm Modifizierung reagiert also nicht auf den Text..
hat da jemand noch eine Idee
Herzliche Grüße
Michael

Moin Zwenn
hier die Beispiele
vorhandenes Dokument mit dem Name "BAG_7330_S_002_Gruppe umweltgefährdende Gefahrstoffe"
Aufruf aus Exceltabelle
https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7330_S_002_DE_Gruppe%20umweltgefährdender%20Gefahrstoffe.pdf
und die "Antwort" der Webseite
https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7330_S_002_DE_Gruppe%20umweltgef%C3%A4hrdender%20Gefahrstoffe.pdf
und
durch Änderung und oder Verschiebung, nicht mehr vorhandenes oder besser nicht mehr erreichbares Dokument mit dem Name "BAG_7332_S_001_Gruppe ätzende Gefahrstoffe"
Aufruf aus Exceltabelle für eine nicht mehr existierende Webseite
https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7332_S_001_DE_Gruppe%20%C3%A4tzende%20Gefahrstoffe.pdf
und die "Antwort" der Webseite mit dem Text "Leider wurde diese Website nicht für Sie freigegeben."
https://applications.bilfinger.net/p/addd7b1ac/VD/_layouts/15/AccessDenied.aspx?Source=https%3A%2F%2Fapplications%2Ebilfinger%2Enet%2Fp%2Faddd7b1ac%2FVD%2FVorgabedokumente%2FBAG%5F7332%5FS%5F001%5FDE%5FGruppe%20%C3%A4tzende%20Gefahrstoffe%2Epdf&correlation=77680aa0%2D7a10%2D20ad%2D877a%2D07eef2c74e81&Type=item&name=6c32438c%2D0269%2D4a86%2D9940%2Dd02e563bd83c&listItemId=10098
Anmerkung: Diese listitemld=10098 am Ende der Webadresse für die nicht mehr erreichbare Seite ändert sich, wenn ich eine andere nicht mehr erreichbare Seite aus meiner Excel Liste aufrufe, das nur für den Fall, das es wichtig sein könnte
und für die Vollständigkeit, die, durch Verschiebung im SharePoint, neu Web Adresse des Dokument
vorher "BAG_7332_S_001_Gruppe ätzende Gefahrstoffe"
nachher "BAG_7330_S_005_DE_Gruppe ätzende Gefahrstoffe"
https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7330_S_005_DE_Gruppe%20%C3%A4tzende%20Gefahrstoffe.pdf
mit der "Antwort" der Web Seite
https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7330_S_005_DE_Gruppe%20%C3%A4tzende%20Gefahrstoffe.pdf
letzteres habe ich eben noch manuell überprüft.
noch fürs Verständnis, BAG heißt Betriebsanweisung Gefahrstoffe :)
ich hoffe Du kannst damit etwas anfangen bzw. mir helfen, da reichen meine Kenntnisse mit Nichten
Schöne Grüße Michael
PS, noch mal das Programm das vorher noch funktioniert hat falls benötigt


Sub CheckURL2_Link()
Sheets("Link").Activate
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("C:E").ClearContents
Set rngBer = Cells(2, 2).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

AADSTS90072: Das Benutzerkonto 'blub@blab.com' vom Identitätsanbieter 'live.com' existiert nicht im Tenant 'Bilfinger' und kann nicht auf die Anwendung 'urn:sharepoint:gcp2016-PROD' (SP-GCP2016 (Production)) in diesem Tenant zugreifen. Das Konto muss zunächst als externer Benutzer im Tenant hinzugefügt werden. Melden Sie sich ab und melden Sie sich erneut mit einem anderen Azure Active Directory-Benutzerkonto an

Sub CheckURL2_Link() Const SEARCH_INVALID As String = "Leider wurde diese Website nicht für Sie freigegeben." 'Vergleichstext für ungültige Seite Dim ws As Worksheet 'Tabelle, auf der gearbeitet werden soll Dim urlAllCells As Range 'Bereich auf ws, in dem die abzuarbeitenden URLs stehen Dim urlOneCell As Range 'Eine Zelle, in der die aktuell abzuarbeitende URL steht Dim url As String 'Die aktuell abzuarbeitende URL aus der Zelle urlOneCell Set ws = ActiveWorkbook.Sheets("Link") 'Festlegung der Arbeitstabelle Set urlAllCells = ws.Cells(2, 2).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1) 'Letzte Zeile des Bereiches für alle URLs urlAllCells.Interior.Pattern = xlNone 'Zurücksetzen der Zellhintergründe auf blank ws.Columns("C:E").ClearContents 'Inhalte der Spalten C bis E auf der Arbeitstabelle löschen 'Mit WinHttp.WinHttpRequest.5.1 habe ich selbst noch nie gearbeitet, 'sollte aber ähnlich funktionieren wie msxml2.xmlhttp.6.0 With CreateObject("WinHttp.WinHttpRequest.5.1") 'Alle Zellen mit URLs durchgehen For Each urlOneCell In urlAllCells 'Die URL aus der aktuellen Zelle lesen url = urlOneCell 'Eine URL muss mind. 5 Zeichen haben If Len(url) > 4 Then 'falls nötig, vorn "http://" ergänzen If LCase(Left(url, 7)) "http://" Then url = "http://" & url 'Den Request durchführen .Open "GET", url .Send 'Unabhängig von der Antwort, werden folgende Werte 'in die Arbeitstabelle eingetragen urlOneCell.Offset(0, 1) = .Status 'HTTP-Status urlOneCell.Offset(0, 2) = .StatusText 'HTTP-Statustext (was der Status aussagt) urlOneCell.Offset(0, 3) = url 'Die verwendete URL 'Prüfen, ob der Ausschlusstext im zurückgelieferten Dokument steht 'Hier wird einfach auf den Text geprüft. Es ist auch möglich, auf 'HTML-Strukturen zu prüfen, falls notwendig If InStr(1, .ResponseText, SEARCH_INVALID) = 0 Then 'Wurde der Ausschlusstext nicht gefunden, 'wird die URL-Zelle mit grün als gültig markiert urlOneCell.Interior.Color = RGB(0, 255, 0) 'grün Else 'Wurde der Ausschlusstext gefunden, wird 'die URL-Zelle mit rot als ungültig markiert urlOneCell.Interior.Color = RGB(255, 0, 0) 'rot End If Else 'Wenn URL kürzer als 5 Zeichen 'Hinweis statt verwendeter URL eintragen urlOneCell.Offset(0, 3) = "URL zu kurz" 'und URL-Zelle gelb markieren urlOneCell.Interior.Color = RGB(0, 255, 255) 'gelb End If Next urlOneCell End With End Sub

Sub CheckURL2_Link() Const SEARCH_INVALID As String = "Leider wurde diese Website nicht für Sie freigegeben." 'Vergleichstext für ungültige Seite Dim ws As Worksheet 'Tabelle, auf der gearbeitet werden soll Dim urlAllCells As Range 'Bereich auf ws, in dem die abzuarbeitenden URLs stehen Dim urlOneCell As Range 'Eine Zelle, in der die aktuell abzuarbeitende URL steht Dim url As String 'Die aktuell abzuarbeitende URL aus der Zelle urlOneCell Set ws = ActiveWorkbook.Sheets("Link") 'Festlegung der Arbeitstabelle Set urlAllCells = ws.Cells(2, 2).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1) 'Letzte Zeile des Bereiches für alle URLs urlAllCells.Interior.Pattern = xlNone 'Zurücksetzen der Zellhintergründe auf blank ws.Columns("C:E").ClearContents 'Inhalte der Spalten C bis E auf der Arbeitstabelle löschen 'Mit WinHttp.WinHttpRequest.5.1 habe ich selbst noch nie gearbeitet, 'sollte aber ähnlich funktionieren wie msxml2.xmlhttp.6.0 With CreateObject("WinHttp.WinHttpRequest.5.1") 'Alle Zellen mit URLs durchgehen For Each urlOneCell In urlAllCells 'Die URL aus der aktuellen Zelle lesen url = urlOneCell 'Eine URL muss mind. 5 Zeichen haben If Len(url) > 4 Then 'falls nötig, vorn "http://" ergänzen If LCase(Left(url, 7)) "http://" Then url = "http://" & url 'Den Request durchführen .Open "GET", url .Send 'Unabhängig von der Antwort, werden folgende Werte 'in die Arbeitstabelle eingetragen urlOneCell.Offset(0, 1) = .Status 'HTTP-Status urlOneCell.Offset(0, 2) = .StatusText 'HTTP-Statustext (was der Status aussagt) urlOneCell.Offset(0, 3) = url 'Die verwendete URL 'Prüfen, ob der Ausschlusstext im zurückgelieferten Dokument steht 'Hier wird einfach auf den Text geprüft. Es ist auch möglich, auf 'HTML-Strukturen zu prüfen, falls notwendig 'Zusätzlich muss der HTTP-Status 200 für ein grundsätzlich gültiges Dokument sein If (InStr(1, .ResponseText, SEARCH_INVALID) = 0) & (.Status = 200) Then 'Wurde der Ausschlusstext nicht gefunden, 'wird die URL-Zelle mit grün als gültig markiert urlOneCell.Interior.Color = RGB(0, 255, 0) 'grün Else 'Wurde der Ausschlusstext gefunden oder ist der HTTP-Status 'ungleich 200, wird die URL-Zelle mit rot als ungültig markiert urlOneCell.Interior.Color = RGB(255, 0, 0) 'rot End If Else 'Wenn URL kürzer als 5 Zeichen 'Hinweis statt verwendeter URL eintragen urlOneCell.Offset(0, 3) = "URL zu kurz" 'und URL-Zelle gelb markieren urlOneCell.Interior.Color = RGB(0, 255, 255) 'gelb End If Next urlOneCell End With End Sub

Sub CheckURL2_Schulungen() ' Dim iOk As Integer Sheets("Link").Select Sheets("Link").Activate Anfang: MsgBox "Test Link aufrufen" MsgBox "ist Link aufgerufen" 'Dim text As String 'text = Sheets("link").Range("B2") ' Set wshshell = CreateObject("WScript.Shell") ' wshshell.Run text 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("C:E").ClearContents Set rngBer = Cells(2, 2).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 ' Dein Code lngS = .Status ' Do ' If .Status 200 Or iOk > 10 Then Exit Do ' Sleep 100 ' iOk = iOk + 1 ' Loop ' If iOk > 9 Then Debug.Print "Seite ncht freigegeben!" If .Status 200 Then GoTo Test1 Dim objXMLHTTP As Object Dim sResult As String Dim von As Long, bis As Long Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP") ' sURL = Sheets("link").Range("B271") ' sURL = "https://applications.bilfinger.net/p/addd7b1ac/VD/Vorgabedokumente/BAG_7332_S_001_DE_Gruppe%20%C3%A4tzende%20Gefahrstoffe.pdf" ' sResult = GetHTTPResult(sURL) objXMLHTTP.Open "GET", sURL, False objXMLHTTP.Send ' MsgBox "Status: " & objXMLHTTP.Status sResult = objXMLHTTP.ResponseText Set objXMLHTTP = Nothing von = InStr(1, sResult, "Leider") ' MsgBox von If von = 0 Then GoTo test bis = InStr(von, sResult, ".") ' MsgBox bis sResult = Mid(sResult, von, bis - von) test: ' MsgBox sResult If sResult = "Leider wurde diese Website nicht für Sie freigegeben" Then 'Sheets("Link").Range("G1").Select lngS = 404 End If Test1: 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 If Sheets("Link").Range("C2") 404 Then GoTo Anfang Next rngC End With On Error GoTo 0 Set oHttpReq = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text in div. Webadressen finden

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread