Recently my boss asked me to come up with a way to show certain information on a map of some kind, and after doing some research I decided to simply create a KML file and use Google Earth. In order to create the KML file, I needed latitude and longitude of each address I was going to display. I found a couple of different free services, and I decided to use the one from Google. The Google Geocode service is using a REST API, so it was easy to write some code to send address and retrieve XML with (among other things) latitude and longitude. An additional benefit is that the address get check and modified, so if the ZIP is off, or the name of the street is not "Street" but "Drive", the correct values get returned. You need to sign up to get your own key from Google, but it is free. Today I decided to write a small class to do this lookup, so now I can add this to any program I write. Below is the code for the script library, as well as a small code sample how to call it. Enjoy!
Dim geodata As GeoData
Set geodata = New GeoData("6363 North State Highway 161", "Irving", "tx", "")
If geodata.IsValid Then
Msgbox geodata.Street & Chr$(13) & geodata.City & ", " & geodata.State & " " & geodata.ZIP,, _ "Accuracy = " & geodata.Accuracy
Msgbox "Lat: " & geodata.Latitude & " Longitude: " & geodata.Longitude
End If
Class GeoData
Private GeoString As String
Public street As String
Public city As String
Public zip As String
Public state As String
Public latitude As String
Public longitude As String
Public Sub New(streetStr As String, cityStr As String, stateStr As String, zipStr As String)
Dim httpObject As Variant
Dim mapsKey As String
Dim mapsURL As String
Dim address As String
Dim retries As Integer
Dim httpURL As String
Dim returncode As String
Dim coordinates As String
Set httpObject = CreateObject("MSXML2.ServerXMLHTTP")
mapsKey = "your key goes here"
mapsUrl = "http://maps.google.com/maps/geo?q="
address = streetStr & ", " & cityStr & ", " & stateStr & " " & zipStr
httpURL = mapsURL & address & "&output=xml&key=" & mapsKey ' Use output=CSV for CSV file
Do
retries = retries + 1
Call httpObject.open("GET", httpURL, False)
Call httpObject.send()
GeoString = Left$(httpObject.responseText,16000)
returncode = GetGeoValue("code")
If retries >= 10 Then
returncode = "500" ' Fake other failure after 10 attempts
End If
Loop Until returncode <> "620"
If returncode = "200" Then
coordinates = GetGeoValue("coordinates")
latitude = Left$(coordinates, Instr(coordinates,",")-1)
longitude = Mid$(coordinates, Len(latitude)+2, Instr(Len(latitude)+2, _ coordinates,",")-Len(latitude)-2)
street =GetGeoValue("ThoroughfareName")
zip = GetGeoValue("PostalCodeNumber")
city = GetGeoValue("LocalityName")
state = GetGeoValue("AdministrativeAreaName")
Msgbox GeoString
Else
GeoString = ""
End If
End Sub
Public Function Accuracy() As Integer
Dim startpos As Long
Dim endpos As Long
If IsValid = False Then
Accuracy = 0
Exit Function
End If
startpos = Instr(Lcase(GeoString),|accuracy="|) + 10
endpos = Instr(startpos, Lcase(GeoString), |"|)
If endpos < startpos Then
Accuracy = 0
Else
Accuracy = Cint(Fulltrim(Mid$(GeoString,startpos, endpos - startpos)))
End If
End Function
Public Function IsValid() As Integer
If GeoString = "" Then
IsValid = False
Else
IsValid = True
End If
End Function
Public Function GetGeoValue(tag As String) As String
Dim startpos As Long
Dim endpos As Long
Dim tempstring As String
If GeoString = "" Then
GetGeoValue = ""
Exit Function
End If
startpos = Instr(Lcase(GeoString),"<" & Lcase(tag) & ">") + Len(tag)
endpos = Instr(startpos, Lcase(GeoString), "</"+Lcase(tag) & ">")
If endpos < startpos Then
GetGeoValue = ""
Else
tempstring = Fulltrim(Mid$(GeoString,startpos+2, endpos - startpos - 2))
GetGeoValue = Fulltrim(R5strReplace(tempstring,"&","&"))
End If
End Function
Private Function R5strReplace(mystring As String, search As String, replace As String) As String
Dim source As String
source = mystring
While Instr(source, search)
|
12
131
|
Title
|
Most Recommendations
|
Most Comments
|
Most Visits