RE: Homevision Question On Weather Data

["Graham Kiff" <graham.kiff@xxxxxxx>]

I currently download weather data from the net which is collected at a
weather station not far from me.  I decode the html page, and store the
data
in a SQL database as well as updating HomeVision via the DDE.

Graham

Here's the snippet, sorry for lack of comments ;-)

Private Sub GetWeatherData()

Dim sHTML As String
Dim lPos1 As Long
Dim lPos2 As Long
Dim asRows() As String
Dim lRow As Long

Dim sDate As String
Dim dDate As Date
Dim dWindSpeed As Double
Dim iWindDir As Integer
Dim dRain As Double
Dim dTempIn As Double
Dim dTempOut As Double
Dim oiBut As iButton

Dim sSQL As String
Dim rs As Recordset
Dim bInsert As Boolean

sbMain.SimpleText = "Downloading weather data"

sHTML = iNet.OpenURL("http://www.dunn.demon.co.uk/weather.html";,
icString)

sbMain.SimpleText = "Decoding weather data"

lPos1 = InStr(1, sHTML, "<TABLE", vbTextCompare)
If lPos1 > 0 Then
lPos1 = InStr(lPos1, sHTML, ">") + 1
lPos2 = InStr(lPos1, sHTML, "</TABLE", vbTextCompare) + 1
lPos2 = InStr(lPos2, sHTML, "</TABLE", vbTextCompare) + 1
lPos2 = InStr(lPos2, sHTML, "</TABLE", vbTextCompare) + 1
lPos2 = InStr(lPos2, sHTML, "</TABLE", vbTextCompare) + 1
lPos2 = InStr(lPos2, sHTML, "</TABLE", vbTextCompare) + 1
lPos2 = InStr(lPos2, sHTML, "</TABLE", vbTextCompare)
If lPos2 > 0 Then
sHTML = Mid$(sHTML, lPos1, lPos2 - lPos1)
sHTML = Replace(sHTML, "&nbsp;", " ", , ,
vbTextCompare)
sHTML = Replace(sHTML, "</TH>", vbTab, , , vbTextCompare)
sHTML = Replace(sHTML, "</TD>", vbTab, , , vbTextCompare)
asRows() = Split(sHTML, "</TR>", , vbTextCompare)
For lRow = 0 To UBound(asRows)
asRows(lRow) = Trim$(StripHTML(asRows(lRow)))
Select Case lRow
Case 0   ' Date/Time
sDate = Trim$(Mid$(asRows(lRow), 13))
While Right$(sDate, 1) = vbTab
sDate = Left$(sDate, Len(sDate) - 1)
Wend
lPos1 = InStr(1, sDate, ":") - 2
sDate = Left$(sDate, lPos1 - 1) & Right$(sDate, 4) & " "
&
Mid$(sDate, lPos1, 8)
dDate = CDate(sDate)
Case 1   ' Wind Dir
lPos1 = InStr(1, asRows(lRow), "(")
lPos1 = InStr(lPos1 + 1, asRows(lRow), "(")
iWindDir = Val(Mid$(asRows(lRow), lPos1 + 1))
Case 2   ' Wind Speed
lPos1 = InStr(1, asRows(lRow), vbTab)
dWindSpeed = Val(Mid$(asRows(lRow), lPos1 + 1))
Case 12  ' Rainfall
lPos1 = InStr(1, asRows(lRow), vbTab)
dRain = Val(Mid$(asRows(lRow), lPos1 + 1))
Case 15  ' Outside Temperature
lPos1 = InStr(1, asRows(lRow), vbTab)
lPos2 = InStr(lPos1, asRows(lRow), "&") - 1
dTempOut = Val(Mid$(asRows(lRow), lPos1 + 1, lPos2 -
lPos1))
End Select
Next lRow


On Error Resume Next
Set oiBut = Nothing
Set oiBut = moiButtonBus.Devices(msTempButton)
On Error GoTo 0

If oiBut Is Nothing Then
dTempIn = -255
Else
dTempIn = Format(oiBut.Data, "0.00")
End If


sbMain.SimpleText = "Updating WeatherData table"

sSQL = "SELECT COUNT(1) " & vbCrLf & _
"FROM WeatherData (NOLOCK) " & vbCrLf & _
"WHERE Date = '" & Format(dDate, "dd/mmm/yyyy
hh:mm:ss") &
"'"
Set rs = goCN.Execute(sSQL)
bInsert = (rs.Fields(0).Value = 0)
rs.Close
Set rs = Nothing

If bInsert Then
sSQL = "INSERT INTO WeatherData " & vbCrLf & _
"(Date, TemperatureIn, TemperatureOut, WindSpeed,
WindDirection, Rainfall) " & vbCrLf & _
"VALUES (" & _
"'" & Format(dDate, "dd/mmm/yyyy hh:mm:ss") &
"', " & _
IIf(dTempIn = -255, "NULL", dTempIn) & ", " & _
dTempOut & ", " & _
dWindSpeed & ", " & _
iWindDir & ", " & _
dRain & ")"
goCN.Execute sSQL



Set rs = goCN.Execute("EXEC GetWeatherData")

' Current Inside Temperature
SendDDECmd Me, BuildDDECmd("^", 0, "00",
Round(IfNull(rs!TemperatureIn, 155) + 100))

' Current Outside Temperature
SendDDECmd Me, BuildDDECmd("^", 0, "03",
Round(IfNull(rs!TemperatureOut, 155) + 100))

' Current Inside Humidity
SendDDECmd Me, BuildDDECmd("^", 0, "06",
Round(IfNull(rs!HumidityIn, 255)))

' Current Outside Humidity
SendDDECmd Me, BuildDDECmd("^", 0, "09",
Round(IfNull(rs!HumidityOut, 255)))

' Wind Speed
SendDDECmd Me, BuildDDECmd("^", 0, "11",
Round(IfNull(rs!WindSpeed, 255)))

' Wind Direction (1st Digit)
SendDDECmd Me, BuildDDECmd("^", 0, "0F",
Val(Left$(Right$("000"
& IfNull(rs!WindDirection, 400), 3), 1)))

' Wind Direction (Digits 2-3)
SendDDECmd Me, BuildDDECmd("^", 0, "10",
Val(Right$("000" &
IfNull(rs!WindDirection, 400), 2)))

' Rain Today (Inches)
SendDDECmd Me, BuildDDECmd("^", 0, "14",
Int(IfNull(rs!Rainfall,
255)))

' Rain Today (Hundreths)
SendDDECmd Me, BuildDDECmd("^", 0, "15",
Round((IfNull(rs!Rainfall, 255) * 100) - (Int(IfNull(rs!Rainfall, 255)) *
100)))

' Barometric Pressure (Inches)
SendDDECmd Me, BuildDDECmd("^", 0, "0C",
Int(IfNull(rs!BaroPress, 255)))

' Barometric Pressure (Hundreths)
SendDDECmd Me, BuildDDECmd("^", 0, "0D",
Round((IfNull(rs!BaroPress, 255) * 100) - (Int(IfNull(rs!BaroPress, 255)) *
100)))

' Barometric Pressure Direction
SendDDECmd Me, BuildDDECmd("^", 0, "0E",
IfNull(rs!BaroPressDir,
255))


Set rs = rs.NextRecordset

' Todays Low Inside Temperature
SendDDECmd Me, BuildDDECmd("^", 0, "01",
Round(IfNull(rs!TemperatureInLo, 155) + 100))

' Todays Low Outside Temperature
SendDDECmd Me, BuildDDECmd("^", 0, "04",
Round(IfNull(rs!TemperatureOutLo, 155) + 100))

' Todays Low Inside Humidity
SendDDECmd Me, BuildDDECmd("^", 0, "07",
Round(IfNull(rs!HumidityInLo, 155) + 100))

' Todays Low Outside Humidity
SendDDECmd Me, BuildDDECmd("^", 0, "0A",
Round(IfNull(rs!HumidityOutLo, 155) + 100))


Set rs = rs.NextRecordset

' Todays High Inside Temperature
SendDDECmd Me, BuildDDECmd("^", 0, "02",
Round(IfNull(rs!TemperatureInHi, 155) + 100))

' Todays High Outside Temperature
SendDDECmd Me, BuildDDECmd("^", 0, "05",
Round(IfNull(rs!TemperatureOutHi, 155) + 100))

' Todays High Inside Humidity
SendDDECmd Me, BuildDDECmd("^", 0, "08",
Round(IfNull(rs!HumidityInHi, 155) + 100))

' Todays High Outside Humidity
SendDDECmd Me, BuildDDECmd("^", 0, "0B",
Round(IfNull(rs!HumidityOutHi, 155) + 100))

rs.Close
Set rs = Nothing

End If
End If
End If

sbMain.SimpleText = ""

End Sub



Public Function BuildDDECmd(sCommand As String, ParamArray avData())

Dim sRetVal As String
Dim lLoop As Long

' Header character
sRetVal = ","

' Command character
sRetVal = sRetVal & Left$(sCommand, 1)

' Data
For lLoop = LBound(avData) To UBound(avData)
If VarType(avData(lLoop)) = vbString Then
sRetVal = sRetVal & avData(lLoop)
Else
sRetVal = sRetVal & Right$("00" &
Hex(Val(avData(lLoop))), 2)
End If
Next lLoop

' Terminator
sRetVal = sRetVal & vbCr

BuildDDECmd = sRetVal

End Function



Public Function SendDDECmd(frmForm As Form, sCommand As String) As Integer
'This function sends the DDE command (a text string) to HomeVision

On Error GoTo ExitError

Dim lTimer As Long

lTimer = Timer
Do While (bDDECommandInProcess And ((Timer - lTimer <= 5) Or Timer <
lTimer))
frmForm.sbMain.SimpleText = "DDE Command in progress..."
DoEvents
Loop
frmForm.sbMain.SimpleText = ""

With frmForm
'First, set DDECmd label to the desired command:
.DDECmd = sCommand
Write2File "HVExtra.log", Format(Now, "dd/mm/yyyy
hh:mm:ss") & " DDE
Command: " & sCommand, True

'Now poke it to HomeVision:
.DDECmd.LinkPoke
End With

'Indicate command sent to HomeVision and waiting for acknowledgement:
bDDECommandInProcess = True

lTimer = Timer
While ((Timer - lTimer) < 0.5) Or (Timer < lTimer)
DoEvents
Wend

SendDDECmd = 0   'OK

Exit Function

ExitError:
SendDDECmd = -1   'ERROR

End Function

>  -----Original Message-----
> From: 	Kenneth Watt [mailto:kennethwatt@xxxxxxx]  On
Behalf Of
> Kenneth Watt
> Sent:	23 April 2001 19:34
> To:	UKHA
> Subject:	[ukha_d] Homevision Question On Weather Data
>
> Guys,
>
> Has anyone found a way to get weather data from the net into HV in any
> way. Excuse me but I'm just starting to play around with some of the
more
> advanced features of HV like this kinda stuff.
>
> Ta
>
> K.
>