TexasSwede

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,"&amp;","&"))
		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) > 0
			source = Left$(source, Instr(source, search) - 1) + replace + _ 
			Right$(source, Len(source) - Instr(source, search) - Len(search) + 1)
		Wend
		R5strReplace = source
	End Function 
	
End Class