152 lines
4.4 KiB
Plaintext
152 lines
4.4 KiB
Plaintext
VERSION 5.00
|
|
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
|
|
Begin VB.Form frmWetterstation
|
|
Caption = "Form1"
|
|
ClientHeight = 3195
|
|
ClientLeft = 60
|
|
ClientTop = 345
|
|
ClientWidth = 4680
|
|
LinkTopic = "Form1"
|
|
ScaleHeight = 3195
|
|
ScaleWidth = 4680
|
|
StartUpPosition = 3 'Windows-Standard
|
|
Begin InetCtlsObjects.Inet Inet1
|
|
Left = 3240
|
|
Top = 870
|
|
_ExtentX = 1005
|
|
_ExtentY = 1005
|
|
_Version = 393216
|
|
End
|
|
End
|
|
Attribute VB_Name = "frmWetterstation"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = False
|
|
Attribute VB_PredeclaredId = True
|
|
Attribute VB_Exposed = False
|
|
Option Explicit
|
|
|
|
Const MUSTERLT = """>LT="
|
|
Const MUSTERRF = """>RF="
|
|
Const MUSTERLD = """>LD="
|
|
|
|
Private mlngError As Long
|
|
Private mstrError As String
|
|
Public strHTML As String
|
|
|
|
Public Function GetError() As String
|
|
GetError = mstrError
|
|
End Function
|
|
|
|
Private Sub Inet1_StateChanged(ByVal State As Integer)
|
|
Debug.Print "inet1: " & Now() & " " & State & ":" & GetStateInfo(State)
|
|
End Sub
|
|
|
|
Public Function HoleWetterdaten(ByVal strURL As String, ByRef dblLT As Double, ByRef dblRF As Double, dblLD As Double, Optional lngTimeout As Long = 30) As Boolean
|
|
Dim lngTime As Long
|
|
On Error GoTo Errorhandler
|
|
|
|
Const INETTIMEOUTMS = 3000
|
|
|
|
lngTime = GetTickCount()
|
|
|
|
Inet1.RequestTimeout = lngTimeout
|
|
mlngError = 0
|
|
mstrError = ""
|
|
|
|
DebugMsg "Wetterstation Abfrage: " & strURL
|
|
Inet1.Execute strURL, "GET"
|
|
Do While Inet1.StillExecuting
|
|
DoEvents
|
|
If GetTickCount() > lngTime + INETTIMEOUTMS Then
|
|
HoleWetterdaten = False
|
|
mstrError = "Timeout " & INETTIMEOUTMS
|
|
Exit Function
|
|
End If
|
|
Loop
|
|
|
|
Dim pos As Long
|
|
Dim strTemp As String
|
|
strHTML = ""
|
|
|
|
If mlngError <> 0 Then
|
|
HoleWetterdaten = False
|
|
Exit Function
|
|
End If
|
|
|
|
Dim strNewData As String
|
|
Do
|
|
strNewData = Inet1.GetChunk(512, icString)
|
|
DoEvents
|
|
If Len(strNewData) = 0 Then Exit Do
|
|
strHTML = strHTML & strNewData
|
|
Loop
|
|
|
|
|
|
If InStr(1, strHTML, "Lufttemperatur") > 0 Then
|
|
HoleWetterdaten = True
|
|
' Lufttemperatur
|
|
pos = InStr(1, strHTML, MUSTERLT) + Len(MUSTERLT)
|
|
strTemp = Trim(Mid(strHTML, pos, 17))
|
|
dblLT = Val(strTemp)
|
|
End If
|
|
|
|
If InStr(1, strHTML, "Relative Luftfeuchte") > 0 Then
|
|
HoleWetterdaten = True
|
|
' Lufttemperatur
|
|
pos = InStr(1, strHTML, MUSTERRF) + Len(MUSTERRF)
|
|
strTemp = Trim(Mid(strHTML, pos, 17))
|
|
dblRF = Val(strTemp)
|
|
End If
|
|
|
|
If InStr(1, strHTML, "Luftdruck") > 0 Then
|
|
HoleWetterdaten = True
|
|
' Lufttemperatur
|
|
pos = InStr(1, strHTML, MUSTERLD) + Len(MUSTERLD)
|
|
strTemp = Trim(Mid(strHTML, pos, 17))
|
|
dblLD = Val(strTemp)
|
|
End If
|
|
|
|
If HoleWetterdaten = False Then
|
|
If mstrError = "" Then
|
|
mstrError = "Konnte aus der HTML-Antwort keine Wetterdaten ermitteln."
|
|
End If
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
mstrError = "Fehler " & Err.Number & " in HoleWetterdaten(): " & Err.Description
|
|
HoleWetterdaten = False
|
|
End Function
|
|
|
|
Private Function GetStateInfo(State As Integer) As String
|
|
'Which state has the control entered?
|
|
Select Case State
|
|
Case icResolvingHost ' 1
|
|
GetStateInfo = " Looking up IP address of host computer"
|
|
Case icHostResolved ' 2
|
|
GetStateInfo = "IP address found"
|
|
Case icConnecting ' 3
|
|
GetStateInfo = "Attempting to connect to Host"
|
|
Case icConnected ' 4
|
|
GetStateInfo = "Connected"
|
|
Case icRequesting ' 5
|
|
GetStateInfo = "Making Request"
|
|
Case icRequestSent ' 6
|
|
GetStateInfo = "Request sent"
|
|
Case icReceivingResponse ' 7
|
|
GetStateInfo = "Receiving Response..."
|
|
Case icResponseReceived ' 8
|
|
GetStateInfo = "Response received"
|
|
Case icDisconnecting ' 9
|
|
GetStateInfo = "Disconnecting"
|
|
Case icDisconnected ' 10
|
|
GetStateInfo = "Disconnected"
|
|
Case icError ' 11
|
|
GetStateInfo = "Error " & Inet1.ResponseCode & " " & Inet1.ResponseInfo
|
|
mlngError = Inet1.ResponseCode
|
|
mstrError = GetStateInfo
|
|
Case icResponseCompleted ' 12
|
|
GetStateInfo = "Response Completed"
|
|
End Select
|
|
End Function
|
|
|