Tabelle von Greenpeace Energy einbauen

Julius · Beitrag von **Julius** » 13.05.2006, 21:36

Hallo!

Wir sind Kunden von Greenpeace Energy. Alle 15 Minuten wird auf der Homepage des Stromanbieters die aktuelle "Zusammensetzung" des Stroms in Form einer Tabelle veröffentlicht.

Seht ihr eine Möglichkeit, diese Tabelle in Samurize einzubinden, sodass ich sie auf meinem Desktop immer aktuell anzeigen lassen kann?
Leider ist die Tabelle kein normales Bild, sonst wäre das ja nicht so schwierig.

Über Tipps würde ich mich freuen!

Danke, Julius

Beitrag von **Tante Google** » 13.05.2006, 21:36

Gumfuzi · Beitrag von **Gumfuzi** » 13.05.2006, 22:44

mmmh, das ist schwer...

Es gibt ein Skript für Samurize, mit dem man aus beliebigen Seiten Daten raussuchen kann und anzeigen lassen kann - habe es mal versucht anzupassen, ohne es getestet zu haben:

Code: Alles auswählen

QuellURL = "http://www.greenpeace-energy.de/strom_barometer.php"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function Strom()
  dim htmlBuffer
  htmlBuffer = ReturnHTML(QuellURL)
  result=NULL
  htmlBuffer = TrimHTMLS(htmlBuffer)
  asdf = instr(htmlBuffer, "Uhr") + 3
  fdsa = instr(htmlBuffer, "Informationen") 
  htmlBuffer = mid(htmlBuffer, asdf, fdsa - asdf)
  Strom = htmlBuffer
End Function

' ---------- intern ----------------------------------------------------
Private Function ReturnHTML(sURL)
	Dim objXMLHTTP,HTML
	Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
	On Error Resume Next
	objXMLHTTP.Open "GET", sURL, False
	objXMLHTTP.Send
	if err = 0 then
		HTML = objXMLHTTP.responseBody
		Set objRS = CreateObject("ADODB.Recordset")
		objRS.Fields.Append "txt", 200, 35000, &H00000080
		objRS.Open
		objRS.AddNew
		objRS.Fields("txt").AppendChunk HTML
		ReturnHTML = objRS("txt").Value
		objRS.Close
		Set objRS = Nothing
	else
		ReturnHTML = "Network error"
	end if
	On Error GoTo 0
	Set objXMLHTTP = Nothing
End Function

Private Function TrimHTMLS(sh)
  str = sh
  str = TrimHTML(str)
  pa = 1
  do until pa > len(str)
    if mid(str, pa, 1) < " " then
     sa = left(str, pa-1)
     sb = mid(str, pa+1)
     str = sa & sb
    else 
      if (mid(str, pa, 1) = " ") and (mid(str, pa+1, 1) = " ") then
       sa = left(str, pa-1)
       sb = mid(str, pa+1)
       str = sa & sb
      else
       pa = pa + 1
      end if
    end if
  loop
  str = replace(str, "&auml;", "ä")
  str = replace(str, "&uuml;", "ü")
  str = replace(str, "&ouml;", "ö")
  str = replace(str, "&Auml;", "Ä")
  str = replace(str, "&Uuml;", "Ü")
  str = replace(str, "&Ouml;", "Ö")
  str = replace(str, "&szlig;", "ß")
  str = replace(str, """, """")
  str = replace(str, "<", "<")
  str = replace(str, ">", ">")
  TrimHTMLS = str
End Function

Private Function TrimKl(sh)              ' eckige Klammer entfernen
  str = sh
  pos_deb = InStr(1, str, "[")
  Do Until pos_deb = 0
      pos_fin = InStr(pos_deb, str, "]")
      part_d = Mid(str, 1, pos_deb - 1)
      part_f = Mid(str, pos_fin + 1, Len(str) - pos_fin)
      str = part_d & part_f
      pos_deb = InStr(1, str, "[")
  Loop
  TrimKl = str
End Function

' ******************************
' Following function by Alderaic
' ******************************

Private Function TrimHTML(sh)
  str = sh
  pos_deb = InStr(1, str, "<")
  Do Until pos_deb = 0
      pos_fin = InStr(pos_deb, str, ">")
      part_d = Mid(str, 1, pos_deb - 1)
      part_f = Mid(str, pos_fin + 1, Len(str) - pos_fin)
      str = part_d & part_f
      pos_deb = InStr(1, str, "<")
  Loop
  TrimHTML = str
End Function

Diesen Code in eine Textdatei kopieren (Notepad) und dann als zB. strom.vbs in C:\Programme\Samurize\Scripts speichern.

Allerdings zeigt es Dir dann alle Werte als eine Ausgabe - falls ich mich jetzt nicht beim Code verguckt habe in der Eile.

Julius · Beitrag von **Julius** » 13.05.2006, 23:41

Vielen Dank für deine Mühe!

Ich habs mal getestet. Ergibt leider ne Fehlermeldung: "Ungültiger Prozdeuraufruf oder ungültiges Argument : 'mid' In strom.vbs (Strom) Linie 10, column 2"

Ich kenne mich leider in Script-Programmierung zu wenig aus, als dass ich den Fehler jetzt suchen könnte. Aber ich gehe mal davon aus, dass es was mit der Zeile

Code: Alles auswählen

htmlBuffer = mid(htmlBuffer, asdf, fdsa - asdf)

zu tun hat.

Kann jemand das Problem lösen? Vielen Dank, Julius

moinmoin · Beitrag von **moinmoin** » 14.05.2006, 10:03

Eine Möglichkeit wäre sonst noch der PageScraper.
Damit kannst du den Bereich einer Seite auslesen lassen den du benötigst.

Gumfuzi · Beitrag von **Gumfuzi** » 14.05.2006, 13:08

probiere es mal so:

Code: Alles auswählen

QuellURL = "http://www.greenpeace-energy.de/strom_barometer.php"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function Strom()
  dim htmlBuffer
  htmlBuffer = ReturnHTML(QuellURL)
  result=NULL
  htmlBuffer = TrimHTMLS(htmlBuffer)
  asdf = instr(htmlBuffer, "Uhr") + 3
  fdsa = instr(htmlBuffer, " Informationen zu den Angaben")
  htmlBuffer = mid(htmlBuffer, asdf, fdsa - asdf)
  Strom = htmlBuffer
End Function

' ---------- intern ----------------------------------------------------
Private Function ReturnHTML(sURL)
   Dim objXMLHTTP,HTML
   Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
   On Error Resume Next
   objXMLHTTP.Open "GET", sURL, False
   objXMLHTTP.Send
   if err = 0 then
      HTML = objXMLHTTP.responseBody
      Set objRS = CreateObject("ADODB.Recordset")
      objRS.Fields.Append "txt", 200, 35000, &H00000080
      objRS.Open
      objRS.AddNew
      objRS.Fields("txt").AppendChunk HTML
      ReturnHTML = objRS("txt").Value
      objRS.Close
      Set objRS = Nothing
   else
      ReturnHTML = "Network error"
   end if
   On Error GoTo 0
   Set objXMLHTTP = Nothing
End Function

Private Function TrimHTMLS(sh)
  str = sh
  str = TrimHTML(str)
  pa = 1
  do until pa > len(str)
    if mid(str, pa, 1) < " " then
     sa = left(str, pa-1)
     sb = mid(str, pa+1)
     str = sa & sb
    else
      if (mid(str, pa, 1) = " ") and (mid(str, pa+1, 1) = " ") then
       sa = left(str, pa-1)
       sb = mid(str, pa+1)
       str = sa & sb
      else
       pa = pa + 1
      end if
    end if
  loop
  str = replace(str, "&auml;", "ä")
  str = replace(str, "&uuml;", "ü")
  str = replace(str, "&ouml;", "ö")
  str = replace(str, "&Auml;", "Ä")
  str = replace(str, "&Uuml;", "Ü")
  str = replace(str, "&Ouml;", "Ö")
  str = replace(str, "&szlig;", "ß")
  str = replace(str, """, """")
  str = replace(str, "<", "<")
  str = replace(str, ">", ">")
  TrimHTMLS = str
End Function

Private Function TrimKl(sh)              ' eckige Klammer entfernen
  str = sh
  pos_deb = InStr(1, str, "[")
  Do Until pos_deb = 0
      pos_fin = InStr(pos_deb, str, "]")
      part_d = Mid(str, 1, pos_deb - 1)
      part_f = Mid(str, pos_fin + 1, Len(str) - pos_fin)
      str = part_d & part_f
      pos_deb = InStr(1, str, "[")
  Loop
  TrimKl = str
End Function

' ******************************
' Following function by Alderaic
' ******************************

Private Function TrimHTML(sh)
  str = sh
  pos_deb = InStr(1, str, "<")
  Do Until pos_deb = 0
      pos_fin = InStr(pos_deb, str, ">")
      part_d = Mid(str, 1, pos_deb - 1)
      part_f = Mid(str, pos_fin + 1, Len(str) - pos_fin)
      str = part_d & part_f
      pos_deb = InStr(1, str, "<")
  Loop
  TrimHTML = str
End Function

Julius · Beitrag von **Julius** » 19.05.2006, 11:12

Vielen Dank für eure Antworten.

Der geänderte Code bringt leider immer noch die gleiche Fehlermeldung.

Jetzt hab ich mich mal an PageScraper gemacht. Ich komme damit aber nicht zurecht. So sehen meine Einstellungen aus:

Bild

Funktioniert aber nicht. Könnt ihr mir sagen, wo der Fehler liegt?
Ich habe schon versucht ein Tutorial zu PageScraper zu finden, aber das scheints nicht zu geben.

Julius