AW: Onlineabfrage klappt nicht
13.11.2019 14:53:42
Zwenn
Hallo Tobi,
ein JavaScript kannst du folgendermaßen auseinandernehmen. Du musst halt sehen, ob das alle Deine benötigten Fälle abdeckt:
Sub PreisAusScriptAuslesen()
Dim browser As Object
Dim url As String
Dim knotenWurzel As Object
Dim knotenStamm As Object
Dim gefunden As Boolean
Dim splitArray() As String
Dim arrElement As Long
Dim betragEuro As String
Dim betragCent As String
Dim betragGanz As Double
url = "https://www.jumbo.ch/de/suche?q=1351049"
'Internet Explorer initialisieren, Sichtbarkeit festlegen,
'URL aufrufen und warten bis Seite vollständig geladen wurde
Set browser = CreateObject("internetexplorer.application")
browser.Visible = False
browser.navigate url
Do Until browser.ReadyState = 4: DoEvents: Loop
'NodeCollection aller script-Tags
Set knotenWurzel = browser.document.getElementsByTagName("script")
If Not knotenWurzel Is Nothing Then
'Wenn die NodeCollection gebildet werden konnte
'Richtiges script suchen
For Each knotenStamm In knotenWurzel
If InStr(1, knotenStamm.innertext, "window.__PRELOADED_STATE__") > 0 Then
gefunden = True
Exit For
End If
Next knotenStamm
If gefunden Then
'Script an den Kommas in Einzelteile zerlegen
splitArray = Split(knotenStamm.innertext, ",")
'Alle Einzelteile durchgehen
For arrElement = 0 To UBound(splitArray)
'Prüfen ob im aktuell betrachteten Einzelteil der String "price": steht
If InStr(1, splitArray(arrElement), Chr(34) & "price" & Chr(34) & ":") > 0 Then
'Wenn ja, sieht das Element so aus: "price":9995
'Dieses am Doppelpunkt wieder aufteilen
splitArray = Split(splitArray(arrElement), ":")
'Das zweite Element des Arrays (die Obergrenze), enthält den Preis ohne Komma
'Also das zweite Element ohne die letzten beiden Stellen merken
betragEuro = Left(Trim(splitArray(UBound(splitArray()))), _
Len(Trim(splitArray(UBound(splitArray())))) - 2)
'Die letzte beiden Stellen des zweiten Array Elements (Obergrenze)
'enthalten den Cent Betrag des Preises
betragCent = Right(Trim(splitArray(UBound(splitArray()))), 2)
'Beide mit Komma dazwischen zusammensetzen und in eine Zahl vom
'Datentyp Double umwandeln
betragGanz = CDbl(betragEuro & "," & betragCent)
Exit For
End If
Next arrElement
End If
'Falls Schleifenverarbeitung
'gefunden zurücksetzen
gefunden = False
End If
'Aufräumen
browser.Quit
Set browser = Nothing
Set knotenWurzel = Nothing
Set knotenStamm = Nothing
'Ausgabe des Preises
MsgBox betragGanz
End Sub
Viele Grüße,
Zwenn