Ik heb een nieuwe bron gevonden voor P2000 berichten.
Deze RSS feed bevat naast de dekking van heel Nederland ook nog enkele andere leuke info. Op basis van deze feed heb ik dit nieuwe script gemaakt. De commandline opties zijn hetzelfde gebleven waardoor het in principe mogelijk is om met dit script het oude script te overschrijven.
Let op
In dit script moet je wel nog enkele settings instellen naar eigen voorkeur.
Nu, wat is er mee mogelijk.
- Meldingen dekking voor heel Nederland
- Filtering mogelijk op text, bijvoorbeeld alleen brandweer
- Filtering op geografisch gebied. Je kan een Lon/Lat coordinaat opgeven en een radius waarna alleen meldingen in dat gebied binnen komen.
- Je thuis coordinaten worden uit HS gehaald maar kunnen genegeerd worden door eigen invoer. Zorg dat deze ingevuld staan in HS Setup\location
- Afbeelding tonen van de locatie waar de melding is (indien aanwezig)
- Link toevoeg zodat wanneer je op de afbeelding klikt direct naar google maps gaat om te zien waar dit precies is.
- 1 to max. 50 laatste meldingen bijhouden.
- Events op meldingen zetten, Een nieuwe melding krijgt een waarde van 1
- De RSS feed kan je ook direct in HSTouch opnemen.
Er zit een bug in HS.
Als je de coordinaten instel in HS (Setup\location) en je kiest amsterdam dan zal je zien dat er een waarde van -4.xxx wordt gekozen Dat klopt niet In Nederland ligt alles in het positive vlak dus dat moet 4.xxx worden. Je kan dat in config\settings.ini aanpassen of in HS dit handmatig invoeren. Of je laat dit staan en verander het alleen in het script.
Namelijk:
Dim Latitude as Decimal = 52.073914
Dim Longitude as Decimal = 5.096970
Code: Select all
' AZ_P2000.vb
' Version : 2.2
' By A.A. van Zoelen
'
'Usage:
'
'AZ_P2000("Main","<DeviceCode>;<number of messages>")
'Example : 'AZ_P2000("Main","W37;5")
'
'
'USAGE with HomeSeer
'Make an event and select script.
'For the parameter field use ("Main","W37;5")
'
'where: ("Main","<DeviceCode>,<Number of messages> ")
'(Note: Main with a capital M)
' <DeviceCode> vb.W37 - is the device code to use as first device
' <Number of messages> vb. 5 (max. 50)
' In this case the top 5 messages are fetched and
' shown in 5 device strings.
' If you ommit this parameter then only 1 device
' will be created.
'
' Remark : P2000 is the Dutch registration and notification system
' used by the police, ambulance and firefighters.
' The script will fetch the top X entries.
'
' History
' v2.3
' Triggering on a new message didn't work correctly
'
' v2.2
' Decoding added for the most used abbreviations
' Gracefully handle connectios errors and time outs
'
' v2.1
' Added extra checks on location coordinates
'
' v2.0
' Complete redesign
'
' v1.2
' Added multi messages support
'
' v1.1
' 25-08-2012
' Added extra filter to make the monitor area smaller
' This is specially nice for cities.
'
' v1.0
' 23-08-2012 : First release
'===================================================================
Imports System.Net
Imports System.IO
Imports System.Math
Public Sub Main(ByVal Params As Object)
'*********************************************
' These variables must be set first
'*********************************************
Dim Debug as boolean
Debug = false
Dim DebugDetails As Boolean
DebugDetails = False
'*********************************************
' The next few variables might be alter if needed
' Use these values to create new device(s)
' If you also use the traffic jam script then
' this is a good moment to name them the same.
Dim strDeviceFloor As String = "Systeem" ' Used in colomn FLOOR
Dim strDeviceRoom As String = "Monitoring" ' Used in column ROOM
Dim strDeviceType As String = "P2000 Monitoring" ' Device type
Dim strLogID As String = "P2000 v2.0" ' Indentifer used in logfile
' This version make use of a RSS feed
' Because of this you can use the same URL
' directly in you HSTouch design if needed.
Dim URL = "http://feeds.livep2000.nl/"
' The above feed covers whole NL
' To put an extra filter on this you can fill in
' the variable below. The result will only be shown
' if this filter apply so be careful what you enter there.
' ** If this isn't within the radius range filled **
' ** in below this then nothing will be found **
' eg. 1024 Search for postcode area
' 1024X A more smaller area
' Streetname
' Ambul ** for ambulance info only
Dim strFilter As String = ""
' Another option is to declare a search area
' around a given location. This circulair area
' area is checked and only if the call is in
' this area then a positive match is made.
' The used location is the lat/lon that
' you have entered on the HS Setup\location page
' To find your use this url http://www.getlatlon.com
' You can overwrite these coordinates by
' entering new coordinates below.
' Leaving them 0 then the HS location is used
' The location in this example is Utrecht, kanaaleiland
' Dim Latitude as Decimal = 52.073914
' Dim Longitude as Decimal = 5.096970
Dim Longitude as Double = 0
Dim Latitude as Double = 0
' The search radius is measured in meters
' Minimum range is 100 meters
' e.g. 500000 = 500 kilometer in all directions.
Dim lngRadius As Long = 5000
' The script can add an image of the
' location where the call is about.
' Options are true or false
Dim blnAddImage As Boolean = true
' If an images is added then this can serve
' as a link to google maps when clicked on it
' Options are true or false
Dim blnImageLink As Boolean = true
'************************************************
' END OF USER SETTINGS
' Below this there is no real need for altering
' anything unless you know what you are doing.
'************************************************
'Make the filter uppercase
strFilter = UCase(strFilter)
'********************************
'Make some checks
'********************************
If blnAddImage <> true Then blnAddImage = false
If blnImageLink <> true Then blnImageLink = false
' If no coordinates are given then reset to HS settings
' If no HS setting are found the reset to Utrecht, kanaaleiland
If Longitude = 0 Then Longitude = CDbl( Replace(hs.GetINISetting("Settings", "longitude", "5.096970"), ".", "," ) )
If Latitude = 0 Then Latitude = CDbl( Replace(hs.GetINISetting("Settings", "latitude", "52.073914") , ".", "," ) )
If lngRadius < 100 Then lngRadius = 100
' Check and see if coordinates are covering NL
Dim strDump As String = ""
strDump = "<b>Location entered <a href='http://maps.google.com/maps?q=" & Replace(CStr(Latitude), "," , ".") & "," & Replace(Cstr(Longitude), "," , ".") & "'>( Click to see )</a></b>"
If Longitude < 3 Or Longitude > 6 then
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", strDump)
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "<b>Home longitude NOT in NL: " & Replace(CStr(Longitude), "," , ".") & " : Ending script !</b>")
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Tip: Controleer je settings in HS onder Setup\location of in het file <hs folder>\config\settings.ini")
Exit Sub
End If
If Latitude < 50 Or Latitude > 54 then
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", strDump)
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "<b>Home latitude NOT in NL: " & Replace(CStr(Latitude), "," , ".") & " : Ending script !</b>")
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Tip: Check your settings in HS under Setup\location or in the file <hs folder>\config\settings.ini")
Exit Sub
End If
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Home longitude : " & Replace(CStr(Longitude), "," , ".") )
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Home latitude : " & Replace(CStr(Latitude), "," , ".") )
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Radius : " & lngRadius )
'********************************
'Get the device code
'********************************
Dim strDevice As String = hs.StringItem(Params, 1, ";")
Dim strHouseCode As String = GetChar(strDevice,1)
Dim strDeviceCode As String = strDevice.subString(1)
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Checking devicecode : " & strHouseCode & strDeviceCode )
'********************************
'Get the number of messages
'to collect and store
'********************************
Dim intNumberOfMessages as Integer = 1
intNumberOfMessages = Val( hs.StringItem(Params, 2, ";") )
If intNumberOfMessages < 1 Then intNumberOfMessages = 1
If intNumberOfMessages > 50 Then intNumberOfMessages = 50
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Checking for " & intNumberOfMessages & " messages max.")
'********************************
'Next do some device checks
'Is the device and house code oke
'********************************
If not ((Val(strDeviceCode)>=1) And (Val(strDeviceCode)<=128)) Then
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "<b>Ongeldige DeviceCode!</b>")
Exit Sub
End If
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Checking houcecode")
If not (strHouseCode <> "") Then
hs.WriteLog("<b>AZ_" & strLogID & "</b>", "<b>Ongeldige HouseCode!</b>")
Exit Sub
End If
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Is device available?")
'********************************
'Are the devices(s) available
'If not then create them
'********************************
Dim i As Integer
For i = 0 To intNumberOfMessages - 1
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Is device " & i & " available?")
If hs.DeviceExistsRef(strHouseCode & Val(strDeviceCode)+i) = -1 Then
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Creating device " & i )
Dim dv As Object
dv = hs.GetDeviceByRef(hs.NewDeviceRef("P2000 message " & i + 1))
dv.hc = strHouseCode
dv.dc = Val(strDeviceCode) + i
dv.misc = "&h10"
dv.location = strDeviceRoom
dv.location2 = strDeviceFloor
dv.dev_type_string = strDeviceType
End If
Next
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Device(s) is (now) available")
'**********************************
' We are ready to get the RSS feed
'**********************************
Dim strXML As String
Try
If Debug = true then hs.writelog("<b>AZ_" & strLogID & "</b>","<b>Trying to retrieve data from : " & URL & "</b>")
Dim myWebRequest As HttpWebRequest = DirectCast(HttpWebRequest.Create(url), HttpWebRequest)
myWebRequest.Method = "GET"
' make request for RSS feed
Dim myWebResponse As HttpWebResponse = DirectCast(myWebRequest.GetResponse(), HttpWebResponse)
Dim myWebSource As New StreamReader(myWebResponse.GetResponseStream())
strXML = myWebSource.ReadToEnd()
myWebResponse.Close()
Catch ex As Exception
hs.setdevicestring(strDevice, URL + " onbereikbaar")
hs.setdevicevalue(strDevice, 0)
hs.setdevicelastchange(strDevice, now)
hs.writelog("<b>AZ_" & strLogID & "</b>","<b>Connection to site failed due : " & ex.Message & "</b>")
Exit Sub
End Try
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "I was able to connect to the RSS feed")
'**********************************
' Check if the page is available.
'**********************************
if Len(strXML) < 100 then
hs.writelog("<b>AZ_" & strLogID & "</b>","<b>" + URL + " returned to few bytes</b>")
hs.setdevicestring(strDevice, URL + " onbereikbaar")
hs.setdevicevalue(strDevice, 0)
hs.setdevicelastchange(strDevice, now)
Exit Sub
End If
'To prevent the hassle with using namespaces
'just get rid of them now
strXML = Replace(strXML, "geo:lat>", "geo_lat>")
strXML = Replace(strXML, "geo:long>", "geo_long>")
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Processing the RSS feed")
'**********************************
' Next we need to grab all the
' the info from the collected data
'**********************************
Dim xmlDoc As Object
Dim itemList As Object
Dim item As Object
Dim Count As Integer
xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.async="false"
xmlDoc.loadXML(strXML)
itemList = xmlDoc.documentElement.SelectNodes("channel/item")
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Aantal nodes:" & itemList.length )
Count = itemList.length
Dim Titel(Count)
Dim TimeStamp(Count) As String
Dim lon(Count) As Double
Dim lat(Count) As Double
Dim Teller as integer = 0
For Each item In itemList
Titel(Teller) = ""
Titel(Teller) = item.SelectSingleNode("title").text
TimeStamp(Teller) = item.SelectSingleNode("pubDate").text
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Titel:" & item.SelectSingleNode("title").text )
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "pubDate:" & item.SelectSingleNode("pubDate").text )
lon(Teller) = 1000
lat(Teller) = 1000
Try
lon(Teller) = CDbl(Replace(item.SelectSingleNode("geo_long").text, ".", "," ) )
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Longitude:" & lon(Teller) )
Catch ex As Exception
lon(Teller) = 1000 'Out of range
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Longitude: NO LONGITUDE")
End Try
Try
lat(teller) = CDbl(Replace(item.SelectSingleNode("geo_lat").text, ".", "," ) )
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Latitude:" & lat(Teller) )
Catch ex As Exception
lat(Teller) = 1000 'Out of range
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Latitude: NO LATITUDE")
End Try
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Afstand:" & afstand( Longitude, Latitude, lon(Teller), lat(Teller) ))
Teller = Teller + 1
Next
'**********************************
' We have all the data we need
' lets do something with it
'**********************************
'Apply filter
'Delete content if filter doesn't apply
If strFilter <> "" Then
For Count = 0 To Teller
If Instr(UCase(Titel(Count)), strFilter) = 0 Then Titel(Count) = ""
Next
End If
'Apply distance only on those
'where Titel is not empty
For Count = 0 To Teller
If Len(Titel(Count)) > 0 Then
'Check if the item has coordinates
If lon(Count) < 1000 And lat(Count) < 1000 Then
If afstand( Longitude, Latitude, lon(Count), lat(Count) ) > lngRadius Then Titel(Count) = ""
If DebugDetails = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Afstand:" & afstand( Longitude, Latitude, lon(Count), lat(Count) ))
Else
Titel(Count) = ""
End If
End If
Next
'Transform text, add an image and
'apply time and date stamp
For Count = 0 To Teller
If Len(Titel(Count)) > 0 Then
'Add date and time stamp
Titel(Count) = TimeStamp(Count) & "</br>" & Titel(Count)
'Replace P2000 codes for something more readable.
Titel(Count) = ReplaceCodes( Titel(Count) )
'Add an image
If lon(Count) <> 1000 And lat(Count) <> 1000 Then
If blnAddImage = true Then Titel(Count) = AddImage(Titel(Count), blnImageLink, lon(Count), lat(Count) )
End If
End If
Next
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "***************************")
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "* Gevonden items die voldoen. *")
If Debug = true then hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "***************************")
If Debug = true then
For Count = 0 To Teller
If Len(Titel(Count)) > 0 Then
hs.WriteLog("<b>AZ_" & strLogID & "_Info</b>", "Titel : " & Titel(Count) )
End If
Next
End If
'**********************************
' We have filtered all the data
' No its time to display things
'**********************************
Dim Test As Boolean = false
Dim Teller2 As Integer = 0
For Count = Teller To 0 Step -1
If Len(Titel(Count)) > 0 Then
'Is this call already in a device
Test = false
For Teller2 = 0 To intNumberOfMessages - 1
If hs.devicestring(strHouseCode & Val(strDeviceCode + Teller2)) = Titel(Count) Then Test = true
Next
If Test = false Then
'Move all calls to the next device and
'then load this call into the first device
If intNumberOfMessages > 1 Then MoveMessages(strHouseCode, strDeviceCode, intNumberOfMessages)
hs.SetDeviceValue(strHouseCode & Val(strDeviceCode), 0)
hs.WaitSecs(1)
hs.SetdeviceString(strHouseCode & Val(strDeviceCode), Titel(Count), true)
hs.SetDeviceValue(strHouseCode & Val(strDeviceCode), 1)
hs.setdevicelastchange(strHouseCode & Val(strDeviceCode), now)
End If
End If
Next
End Sub
'********************************
'********************************
' Additional functions and such
'********************************
'********************************
' Replace the P2000 codes with
' something more readable
Function ReplaceCodes(ByVal Titel as String) As String
Titel = UCase(Titel)
Titel = Replace(Titel, "</BR>A1 ", "</br>Ambulance met optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>A2 ", "</br>Ambulance zonder optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>B ", "</br>Besteld vervoer. ")
Titel = Replace(Titel, " A1 ", " Ambulance met optische en akoestische signalen. ")
Titel = Replace(Titel, " A2 ", " Ambulance zonder optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>PRIO: 1 ", "</br>Brandweer met optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>PRIO: 2 ", "</br>Brandweer met mogelijk optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>PRIO: 3 ", "</br>Brandweer. ")
Titel = Replace(Titel, "</BR>PRIO 1 ", "</br>Brandweer met optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>PRIO 2 ", "</br>Brandweer met mogelijk optische en akoestische signalen. ")
Titel = Replace(Titel, "</BR>PRIO 3 ", "</br>Brandweer. ")
Titel = Replace(Titel, "</BR>BR ", "</br>Brandweer. ")
Titel = Replace(Titel, "</BR>P ", "</br>Personenauto. ")
Return Titel
End Function
'
'Do some markup to the status of the device
'Add an images and a link if requested
'
Function AddImage(ByVal strStatus As String, ByVal blnImageLink As Boolean, ByVal Longitude As Double, Byval Latitude As Double ) As String
strStatus = strStatus & "</br>"
If blnImageLink = true then
strStatus = strStatus & "<a href='http://maps.google.com/maps?q="
strStatus = strStatus & Replace(CStr(latitude), "," , ".") & "," & Replace(CStr(Longitude), ",", ".")
strStatus = strStatus & "'></br>"
End If
strStatus = strStatus & "<img src='"
strStatus = strStatus & "http://cbk3.google.com/cbk?output=thumbnail&cb_client=maps_sv&thumb=2&ll="
strStatus = strStatus & Replace(CStr(latitude), "," , ".") & "," & Replace(CStr(Longitude), ",", ".") & "&w=300&h=118"
strStatus = strStatus & " ' >"
If blnImageLink = true then
strStatus = strStatus & "</a>"
End If
Return strStatus
End Function
'Move the messages from the first device
'into the next device and cascade this
'to the last device
Sub MoveMessages(ByVal HC As String, ByVal DC As String, Byval Devices As Integer)
Dim i As Integer = 0
For i = Devices To 1 Step -1
hs.Setdevicestring(HC & Val(DC + i), hs.devicestring(HC & Val(DC + i - 1)), true)
hs.SetdeviceValue(HC & Val(DC + i - 1), 0)
hs.SetdeviceLastChange(HC & Val(DC + i), now)
hs.SetdeviceStatus(HC & Val(DC + i), hs.deviceStatus(HC & Val(DC + i - 1)) )
Next
End Sub
'
' Calculate the distance
'
Function Afstand(Byval lon1 As Double, Byval lat1 As Double, Byval lon2 As Double, Byval lat2 As Double) As Long
Dim theta As Double
Dim dist As Double
theta = lon1 - lon2
dist = sin(deg2rad(lat1)) * sin(deg2rad(lat2)) + cos(deg2rad(lat1)) * cos(deg2rad(lat2)) * cos(deg2rad(theta))
dist = acos(dist)
dist = rad2deg(dist)
dist = dist * 60 * 1.1515
' Convert from miles to meters
dist = (dist * 1.609344) * 1000
Return CLng(dist)
End Function
'
' This function get the arccos function from arctan function
'
Function acos(rad)
Dim Pi As Double = 3.14159265358979323846
If Abs(rad) <> 1 Then
acos = pi/2 - Atan(rad / Sqrt(1 - rad * rad))
ElseIf rad = -1 Then
acos = pi
End If
End function
'
' This function converts decimal degrees to radians
'
Function deg2rad(Deg)
Dim Pi As Double = 3.14159265358979323846
deg2rad = CDbl(Deg * pi / 180)
End Function
'
' This function converts radians to decimal degrees
'
Function rad2deg(Rad)
Dim Pi As Double = 3.14159265358979323846
rad2deg = CDbl(Rad * 180 / pi)
End Function