Latitude Longitude Functions
Working with distance, latitude and longitude in Excel
This page presents various methods for acquiring latitude and longitude in Excel, as well as driving distance. The code on this page is somewhat old and I am planning at some point to refactor it.
Driving Distance MapQuest UDF
Here is a UDF for getting driving distance from MapQuest, based on cells in your worksheet.
Let's say you have a starting address in cells A1 (street), B1 (city), C1 (state), D1 (zip), and the destination address is E1 (street), F1 (city), G1 (state), H1 (zip). This function pulls the address from the cells in Excel, creates an instance of Internet Explorer, passes the addresses to MapQuest and returns the driving distance to the target cell. If there is an error with MapQuest, it shows a friendly error message.
Update 10/31/08: MapQuest reorged their page and broke the UDF. I've updated the URL string, and also added a call to the Refresh Method. This is required to make the driving distance appear programmatically.
' must set references to Microsoft VBScript Regular Expressions, Internet Controls
' & HTML Object Library before running this script
' based on http://www.vbaexpress.com/kb/getarticle.php?kb_id=386
Public Function GetDistance(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String
Dim sURL As String
Dim appIE As InternetExplorer
Dim regex As RegExp, Regmatch As MatchCollection
Dim BodyTxt As String
Dim GetFirstPos As Long
sURL = "http://www.mapquest.com/maps?1c=" & Replace(startCity, " ", "+")
sURL = sURL & "&1s=" & startState & "&1a=" & Replace(startAddr, " ", "+")
sURL = sURL & "&1z=" & startZip & "&2c=" & endCity & "&2s=" & endState
sURL = sURL & "&2a=" & Replace(endAddr, " ", "+") & "&2z=" & endZip
Set appIE = New InternetExplorer
'Set appIE = CreateObject("Internetexplorer.application")
appIE.navigate sURL
appIE.Visible = True
Do
DoEvents
Loop Until appIE.readyState = READYSTATE_COMPLETE
appIE.Refresh
Set regex = New RegExp
With regex
.Pattern = "Total Estimated Distance"
.MultiLine = False
End With
BodyTxt = appIE.document.Body.innerText
Set Regmatch = regex.Execute(BodyTxt)
If Regmatch.Count > 0 Then
GetFirstPos = WorksheetFunction.Find("Total Estimated Distance", BodyTxt, 1)
GetDistance = Mid$(BodyTxt, GetFirstPos, 30)
Else
GetDistance = "Address Error, fix and try again"
End If
appIE.Quit
Set appIE = Nothing
Set regex = Nothing
Set Regmatch = Nothing
End Function
This function should be used in a worksheet as follows:
=GetDistance(A1,B1,C1,D1,E1,F1,G1,H1)
Now note that it will return an error if you include suite or apartment numbers in the house number. Also if you include hash marks "#" it will fail. Also keep in mind you are opening Internet Explorer in the background and waiting for MapQuest to load, so there will be an approx 6 second delay between you entering the function and it actually returning a result. Also I recommend that after entering the function and getting the result, you either paste in the value or delete it and re-enter it if needed — the function is volatile and you will end up re-running the code inadvertently, which will slow down your computer to a crawl.
Great Circle Distance UDF using Yahoo API and XML
Yahoo provides a nifty geocoding API which we can use to return latitude and longitude information, based on a given street address. Here I will show a simple UDF that uses XML to return this data to two string variables, which can be used in other VBA procedures or directly in the worksheet.
I have previously posted some sample code showing how to get driving distance into Excel, namely
- Website Parsing/Retrieval using XML
- The GetDistance() function above.
The first thing I did was go to the following website and create a Yahoo API: Yahoo Developer Network and the website that explains how it works is here: Yahoo Geocoding API
To construct the URL, I simply used the sample URL from their site (see below) and replaced the appid with the one I created using the link above. When you create your own appid, it should be placed in the URL below, between "appid=" and "&street". Then we can use function arguments to pass the additional parameters (city, state and zip).
http://local.yahooapis.com/MapsService/V1/geocode?appid=sGmf70bV34H6QgDaDk.tLer1VOJZEf.P7nZPi2V8MMmFDEQ_f30ByzwxgTI-&street=701+First+Ave&city=Sunnyvale&state=CA
Then it is simply a matter of using the stock code from Website Parsing/Retrieval using XML and using text functions like Instr, Left$, Mid$ and Len to extract the latitude and longitude from the returned XML response.
Remember to set a reference to Microsoft XML, v6.0 (c:\WINDOWS\system32\msxml6.dll on my system) in the VB Editor. See the Binding page for help setting up references to object libraries.
strStartState As String, strEndAddr As String, strEndCity As String, _
strEndState As String) As Double
'
' Jimmy Pena 4-2-2008
' http://www.codeforexcelandoutlook.com
'
' uses formula from http://www.cpearson.com/excel/latlong.htm with slight mod
Dim MyStartLat As String
Dim MyStartLong As String
Dim MyEndLat As String
Dim MyEndLong As String
MyStartLat = GetLatitude(strStartAddr, strStartCity, strStartState)
MyStartLat = CDec(MyStartLat)
MyStartLong = GetLongitude(strStartAddr, strStartCity, strStartState)
MyStartLong = CDec(MyStartLong)
MyEndLat = GetLatitude(strEndAddr, strEndCity, strEndState)
MyEndLat = CDec(MyEndLat)
MyEndLong = GetLongitude(strEndAddr, strEndCity, strEndState)
MyEndLong = CDec(MyEndLong)
With WorksheetFunction
GCDist = Format(3958.756 * .Acos(Cos(.Radians(90 - (MyStartLat))) * _
Cos(.Radians(90 - (MyEndLat))) + Sin(.Radians(90 - (MyStartLat))) * _
Sin(.Radians(90 - (MyEndLat))) * _
Cos(.Radians((MyStartLong - MyEndLong)))), "####.##")
End With
End Function
strState As String) As String
Dim sURL As String
Dim FirstPos As Long
Dim LastPos As Long
Dim xmlSite As XMLHTTP60
Set xmlSite = New XMLHTTP60
sURL = "http://local.yahooapis.com/MapsService/V1/geocode?" & _
"appid=sGmf70bV34H6QgDaDk.tLer1VOJZEf.P7nZPi2V8MMmFDEQ_f30ByzwxgTI-" & _
"&street=" & Replace(strStreet, " ", "+") & "&city=" & strCity & _
"&state=" & strState
xmlSite.Open "GET", sURL, False
xmlSite.Send
Do Until xmlSite.readyState = 4
Loop
FirstPos = InStr(xmlSite.responseText, "Latitude") + 9
LastPos = InStr(FirstPos + 1, xmlSite.responseText, "/Latitude") - 1
GetLatitude = Mid$(xmlSite.responseText, FirstPos, LastPos - FirstPos)
Set xmlSite = Nothing
End Function
strState As String) As String
Dim sURL As String
Dim FirstPos As Long
Dim LastPos As Long
Dim xmlSite As XMLHTTP60
Set xmlSite = New XMLHTTP60
sURL = "http://local.yahooapis.com/MapsService/V1/geocode?" & _
"appid=sGmf70bV34H6QgDaDk.tLer1VOJZEf.P7nZPi2V8MMmFDEQ_f30ByzwxgTI-" & _
"&street=" & Replace(strStreet, " ", "+") & "&city=" & strCity & _
"&state=" & strState
xmlSite.Open "GET", sURL, False
xmlSite.Send
Do Until xmlSite.readyState = 4
Loop
FirstPos = InStr(xmlSite.responseText, "Longitude") + 10
LastPos = InStr(FirstPos + 1, xmlSite.responseText, "/Longitude") - 1
GetLongitude = Mid$(xmlSite.responseText, FirstPos, LastPos - FirstPos)
Set xmlSite = Nothing
End Function
To use, you should have a starting address, city and state in separate cells (ex: A1:A3), and destination address, city and state in separate cells (ex: B1:B3) type =GCDist(A1,A2,A3,B1,B2,B3) in a cell and press Enter. You could also type the arguments directly into the parenthesis, for example:
=GCDist("123 Main St","Queens","NY","100 Main Blvd","Ames","IA")
The first thing you may notice is just how much faster this is than the GetDistance() function above. Keep in mind, though, that even though it is much faster, less volatile and less prone to error, this function returns great circle ("as the crow flies") distances, where the GetDistance() function returns actual door to door distance (much more useful in my opinion).
The first thing the function does is pass the arguments to the "real" functions, a series of functions declared Private so they are only accessible from the GCDist() function. i.e. they can't be found in the GUI. These functions, GetLatitude() and GetLongitude(), use the XMLHTTP60 object to open a request to the Yahoo website, pass the URL and grab the return text, then parse it for the latitute and longitude (respectively).
These values are returned to the GCDist function, converted to decimal values (CDec), then passed to the formula (courtesy of Chip Pearson's website) which calculates the great circle distance.
I use the Replace() function because if you notice in the sample URL there are plus signs where there are usually spaces in the street address. Since we can't have spaces in the URL, we replace them with plus signs wherever found.
Get Latitude and Longitude using XML
We can also use web services to look up latitude and longitude. WebserviceX.net offers a few free web APIs for consuming weather information. Fortunately, this service also returns the latitude and longitude for a given zip code. Paste the following into a standard module and run the TestGetLatLong function.
The GetLatitudebyZip and GetLongitudeByZip functions create temporary XML files and do a rudimentary parsing for the latitude and longitude found therein. The temp file is removed after processing. You could easily combine these two functions to return both the latitude and longitude. For example, as an array.
Sub TestGetLatLong()
Debug.Print GetLatitudeByZip("11103")
Debug.Print GetLongitudeByZip("11103")
End Sub
Function GetLatitudeByZip(ZipCode As String) As Double
' http://www.webservicex.net/WCF/ServiceDetails.aspx?SID=44
' requires %windir%\system32\msxml2.dll
Dim xml As Object
Dim result As String
Dim nextFileNum As Long
Dim tempFile As String
Dim doc As Object
Dim objRoot As Object
Dim objChild As Object
' create XML document with weather info (which also
' contains lat/long)
Set xml = CreateObject("MSXML2.XMLHTTP")
xml.Open "GET", _
"http://www.webservicex.net/WeatherForecast.asmx/GetWeatherByZipCode?ZipCode=" & ZipCode, False
xml.Send
result = xml.responsetext
' write to temp xml file
nextFileNum = FreeFile
tempFile = Environ("temp") & Application.PathSeparator & ZipCode & XML_FILE_EXTENSION
Open tempFile For Output As #nextFileNum
Print #nextFileNum, result
Close #nextFileNum
' create new XML doc
Set doc = CreateObject("MSXML2.DOMDocument")
doc.validateOnParse = False
doc.Load tempFile
Set objRoot = doc.documentElement
' loop through top-level children
For Each objChild In objRoot.childNodes
If objChild.nodeName = "Latitude" Then
GetLatitudeByZip = objChild.Text
Kill tempFile
Exit Function
End If
Next objChild
End Function
Function GetLongitudeByZip(ZipCode As String) As Double
' http://www.webservicex.net/WCF/ServiceDetails.aspx?SID=44
' requires %windir%\system32\msxml2.dll
Dim xml As Object
Dim result As String
Dim nextFileNum As Long
Dim tempFile As String
Dim doc As Object
Dim objRoot As Object
Dim objChild As Object
' create XML document with weather info (which also
' contains lat/long)
Set xml = CreateObject("MSXML2.XMLHTTP")
xml.Open "GET", _
"http://www.webservicex.net/WeatherForecast.asmx/GetWeatherByZipCode?ZipCode=" & ZipCode, False
xml.Send
result = xml.responsetext
' write to temp xml file
nextFileNum = FreeFile
tempFile = Environ("temp") & Application.PathSeparator & ZipCode & XML_FILE_EXTENSION
Open tempFile For Output As #nextFileNum
Print #nextFileNum, result
Close #nextFileNum
' create new XML doc
Set doc = CreateObject("MSXML2.DOMDocument")
doc.validateOnParse = False
doc.Load tempFile
Set objRoot = doc.documentElement
' loop through top-level children
For Each objChild In objRoot.childNodes
If objChild.nodeName = "Longitude" Then
GetLongitudeByZip = objChild.Text
Kill tempFile
Exit Function
End If
Next objChild
End Function
Latitude and Longitude from Geonames
Geonames is a web service that returns geographical information from its database. It also returns latitude and longitude for select functions.
The following function may be used (within the United States) to return the latitude and longitude for a given zip code. It's approximate, but good enough for many purposes.
Don't forget to paste the helper functions into a standard module in the same project.
Optional radius As Long = 10, _
Optional maxRows As Long = 1) As String()
Dim xml As Object ' MSXML2.XMLHTTP
Dim result As String
Dim tempFile As String
Dim tempString() As String
Dim xmlDoc As Object ' MSXML2.DOMDocument
Dim geoNames As Object ' MSXML2.IXMLDOMNode
Dim code As Object ' MSXML2.IXMLDOMNode
Dim i As Long
tempFile = Environ("temp") & "\" & postCode & "latlong.xml"
If Len(Dir(tempFile)) = 0 Then
Set xml = CreateObject("MSXML2.XMLHTTP")
xml.Open "GET", "http://ws.geonames.org/findNearbyPostalCodes?postalcode=" & _
postCode & "&country=" & countryCode & "&radius=" & radius & _
"&maxRows=" & maxRows & "&type=xml", False
xml.send
result = ConvertAccent(xml.responseText)
' create XML file from result
Call CreateXMLFile(tempFile, result)
End If
' create XML doc
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
With xmlDoc
.async = False
.validateOnParse = False
.Load tempFile
End With
' check that the XML doc loaded
If LoadError(xmlDoc) Then
Exit Function
End If
' get first level nodes
Set geoNames = xmlDoc.childNodes(1)
' resize array
ReDim tempString(1 To 2)
' the first and only node
Set code = geoNames.childNodes(0)
tempString(1) = code.childNodes(3).nodeTypedValue
tempString(2) = code.childNodes(4).nodeTypedValue
GetLatLong = tempString
End Function
The function returns latitude and longitude as a String array; the first element is latitude, the second is longitude.
Dim results() As String
Dim latitude As String
Dim longitude As String
results = GetLatLong("11103")
latitude = results(1)
longitude = results(2)
End Sub
Helper Functions
These functions are used by the Geonames function; make sure you paste them into a standard module in the same project.
' returns child nodes for a given MSXML2.IXMLDOMNode
Set GetChildNodes = node.childNodes
End Function
Function CreateXMLFile(fileName As String, contents As String) As String
' creates XML file from string contents
Dim tempFile As String
Dim nextFileNum As Long
nextFileNum = FreeFile
tempFile = fileName
Open tempFile For Output As #nextFileNum
Print #nextFileNum, FixAngleBrackets(contents)
Close #nextFileNum
CreateXMLFile = tempFile
End Function
Function GetRootNode(xmlDoc As Object) As Object
' returns root node
Set GetRootNode = xmlDoc.documentElement
End Function
Function GetNode(parentNode As Object, nodeNumber As Long) As Object
On Error Resume Next
' if parentNode is a MSXML2.IXMLDOMNodeList
Set GetNode = parentNode.item(nodeNumber - 1)
' if parentNode is a MSXML2.IXMLDOMNode
If GetNode Is Nothing Then
Set GetNode = parentNode.childNodes(nodeNumber - 1)
End If
End Function
Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
LoadError = (xmlDoc.parseError.errorCode <> 0)
End Function
Function ClearCache(Optional fileExtension As String = "xml")
' deletes stored xml files from temp folder
Dim filesToDelete As String
filesToDelete = environ("temp") & "\*." & fileExtension
Kill filesToDelete
End Function
Function FixAngleBrackets(textString As String) As String
FixAngleBrackets = Replace(Replace(textString, "<", "<"), ">", ">")
End Function
Function ConvertAccent(ByVal inputString As String) As String
' http://www.vbforums.com/archive/index.php/t-483965.html
Const AccChars As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
Const RegChars As String = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
Dim i As Long, j As Long
Dim tempString As String
Dim currentCharacter As String
Dim found As Boolean
Dim foundPosition As Long
tempString = inputString
' loop through the shorter string
Select Case True
Case Len(AccChars) <= Len(inputString)
' accent character list is shorter (or same)
' loop through accent character string
For i = 1 To Len(AccChars)
' get next accent character
currentCharacter = Mid$(AccChars, i, 1)
' replace with corresponding character in "regular" array
If InStr(tempString, currentCharacter) > 0 Then
tempString = Replace(tempString, currentCharacter, Mid$(RegChars, i, 1))
End If
Next i
Case Len(AccChars) > Len(inputString)
' input string is shorter
' loop through input string
For i = 1 To Len(inputString)
' grab current character from input string and determine if it is a special char
currentCharacter = Mid$(inputString, i, 1)
found = (InStr(AccChars, currentCharacter) > 0)
If found Then
' find position of special character in special array
foundPosition = InStr(AccChars, currentCharacter)
' replace with corresponding character in "regular" array
tempString = Replace(tempString, currentCharacter, Mid$(RegChars, foundPosition, 1))
End If
Next i
End Select
ConvertAccent = tempString
End Function
For more Geonames API functions, visit my blog.
Latitude and longitude using Business.Gov API
We can also return latitude and longitude using the Business.Gov API. It returns latitude and longitude for a city/state combination (U.S. only). While this isn't as accurate as lat/lon for a street address, it may be good enough for your needs.
To use this function you'll need the URLEncode function, as well as the helper functions used elsewhere.
' uses business.gov API to get latitude and
' longitude for a city/state combo
Dim xml As Object ' MSXML2.XMLHTTP
Dim tempFile As String
Dim tempString() As String
Dim result As String
Dim xmlDoc As Object ' MSXML2.DOMDocument
Dim xmlDocRoot As Object ' MSXML2.IXMLDOMNode
Dim sites As Object ' MSXML2.IXMLDOMNodeList
Dim site As Object ' MSXML2.IXMLDOMNode
Dim i As Long, j As Long
Dim state As String
state = GetStateAbbr(stateAbbr)
Const TEMP_FILENAME As String = "LatLong"
Const XML_FILE_EXTENSION As String = ".xml"
' if XML file exists, don't requery website
tempFile = environ("temp") & "\" & TEMP_FILENAME & state & city & XML_FILE_EXTENSION
If Len(Dir(tempFile)) = 0 Then
Set xml = CreateObject("MSXML2.XMLHTTP")
With xml
.Open "GET", _
"http://api.business.gov/geodata/all_links_for_city_of/" & _
URLEncode(city) & "/" & state & ".xml", False
.send
End With
result = ConvertAccent(xml.responseText)
' save result as temp XML document
tempFile = CreateXMLFile(tempFile, result)
End If
' load XML file into new XML document
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
With xmlDoc
.async = False
.validateOnParse = False
.Load tempFile
End With
' check that the XML doc loaded
If LoadError(xmlDoc) Then
Exit Function
End If
' get root node
Set xmlDocRoot = GetRootNode(xmlDoc)
' get first level child nodes
Set sites = GetChildNodes(xmlDocRoot)
' resize array
ReDim tempString(1 To 2)
Set site = sites.item(0)
tempString(1) = site.childNodes.item(10).nodeTypedValue
tempString(2) = site.childNodes.item(11).nodeTypedValue
GetLatLong = tempString
End Function
You'll also need the following Enum section, and a function to translate the constant into a String. Paste it at the top of a standard module in the same project. The GetStateAbbr function translates the constant into a string needed for the GetLatLong function.
ALABAMA
ALASKA
AMERICAN_SAMOA
ARIZONA
ARKANSAS
CALIFORNIA
COLORADO
CONNECTICUT
DELAWARE
DISTRICTOFCOLUMBIA
MICRONESIA
FLORIDA
GEORGIA
GUAM
HAWAII
IDAHO
ILLINOIS
INDIANA
IOWA
KANSAS
KENTUCKY
LOUISIANA
MAINE
MARSHALL_ISLANDS
MARYLAND
MASSACHUSETTS
MICHIGAN
MINNESOTA
MISSISSIPPI
MISSOURI
MONTANA
NEBRASKA
NEVADA
NEW_HAMPSHIRE
NEW_JERSEY
NEW_MEXICO
NEW_YORK
NORTH_CAROLINA
NORTH_DAKOTA
NORTHERN_MARIANA_ISLANDS
OHIO
OKLAHOMA
OREGON
PALAU
PENNSYLVANIA
PUERTO_RICO
RHODE_ISLAND
SOUTH_CAROLINA
SOUTH_DAKOTA
TENNESSEE
TEXAS
UTAH
VERMONT
VIRGIN_ISLANDS
VIRGINIA
WASHINGTON
WEST_VIRGINIA
WISCONSIN
WYOMING
End Enum
Function GetStateAbbr(stateAbbr As stateAbbr) As String
Select Case stateAbbr
Case 0: GetStateAbbr = "AL"
Case 1: GetStateAbbr = "AK"
Case 2: GetStateAbbr = "AS"
Case 3: GetStateAbbr = "AZ"
Case 4: GetStateAbbr = "AR"
Case 5: GetStateAbbr = "CA"
Case 6: GetStateAbbr = "CO"
Case 7: GetStateAbbr = "CT"
Case 8: GetStateAbbr = "DE"
Case 9: GetStateAbbr = "DC"
Case 10: GetStateAbbr = "FM"
Case 11: GetStateAbbr = "FL"
Case 12: GetStateAbbr = "GA"
Case 13: GetStateAbbr = "GU"
Case 14: GetStateAbbr = "HI"
Case 15: GetStateAbbr = "ID"
Case 16: GetStateAbbr = "IL"
Case 17: GetStateAbbr = "IN"
Case 18: GetStateAbbr = "IA"
Case 19: GetStateAbbr = "KS"
Case 20: GetStateAbbr = "KY"
Case 21: GetStateAbbr = "LA"
Case 22: GetStateAbbr = "ME"
Case 23: GetStateAbbr = "MH"
Case 24: GetStateAbbr = "MD"
Case 25: GetStateAbbr = "MA"
Case 26: GetStateAbbr = "MI"
Case 27: GetStateAbbr = "MN"
Case 28: GetStateAbbr = "MS"
Case 29: GetStateAbbr = "MO"
Case 30: GetStateAbbr = "MT"
Case 31: GetStateAbbr = "NE"
Case 32: GetStateAbbr = "NV"
Case 33: GetStateAbbr = "NH"
Case 34: GetStateAbbr = "NJ"
Case 35: GetStateAbbr = "NM"
Case 36: GetStateAbbr = "NY"
Case 37: GetStateAbbr = "NC"
Case 38: GetStateAbbr = "ND"
Case 39: GetStateAbbr = "MP"
Case 40: GetStateAbbr = "OH"
Case 41: GetStateAbbr = "OK"
Case 42: GetStateAbbr = "OR"
Case 43: GetStateAbbr = "PW"
Case 44: GetStateAbbr = "PA"
Case 45: GetStateAbbr = "PR"
Case 46: GetStateAbbr = "RI"
Case 47: GetStateAbbr = "SC"
Case 48: GetStateAbbr = "SD"
Case 49: GetStateAbbr = "TN"
Case 50: GetStateAbbr = "TX"
Case 51: GetStateAbbr = "UT"
Case 52: GetStateAbbr = "VT"
Case 53: GetStateAbbr = "VI"
Case 54: GetStateAbbr = "VA"
Case 55: GetStateAbbr = "WA"
Case 56: GetStateAbbr = "WV"
Case 57: GetStateAbbr = "WI"
Case 58: GetStateAbbr = "WY"
End Select
End Function
Sample usage
Dim results() As String
Dim latitude As String
Dim longitude As String
results = GetLatLong(NEW_YORK, "Albany")
latitude = results(1)
longitude = results(2)
End Sub
Abbreviations.com Zip Codes API returns Latitude and Longitude
Here's yet another way to get latitude and longitude. Will it ever stop?
To use the Zip Codes API from Abbreviations.com, visit their API page. You'll need an API key to use the following function. I have an API key (they call it a "token ID"), but in the sample code below it has been removed.
This function takes a zip code and returns the latitude and longitude as an array. It's not as accurate as a street address, but might be close enough for most purposes. It is late bound but uses MSXML2.DLL which should be located in your %windir%\system32 folder.
Note: The second and third values of the returned String array contain the latitude and longitude for the given zip code.
Function GetLatLong(tokenID As String, zipCode As String, _
Optional forceRequery As Boolean = False) As String()
Dim xml As Object ' MSXML2.XMLHTTP
Dim result As String
Dim tempFolder As String
Dim tempFile As String
Dim tempString() As String
Dim xmlDoc As Object ' MSXML2.DOMDocument
Dim xmlDocRoot As Object ' MSXML2.IXMLDOMNode
Dim results As Object ' MSXML2.IXMLDOMNodeList
Dim resultNode As Object ' MSXML2.IXMLDOMNode
Const XML_FILE_EXTENSION As String = ".xml"
tempFolder = environ("temp") & "\"
tempFile = tempFolder & zipCode & XML_FILE_EXTENSION
' requery if cache file is missing or forceRequery set to True
If Len(Dir(tempFile)) = 0 Or forceRequery Then
Set xml = CreateObject("MSXML2.XMLHTTP")
With xml
.Open "GET", zip_base_URL & "?tokenid=" & tokenID & "&zip=" & zipCode, False
.send
End With
result = xml.responseText
CreateXMLFile tempFile, ConvertAccent(result)
End If
' load XML file into new XML document
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
With xmlDoc
.async = False
.validateOnParse = False
.Load tempFile
End With
' check that the XML doc loaded
If LoadError(xmlDoc) Then
Exit Function
End If
' get root node
Set xmlDocRoot = GetRootNode(xmlDoc)
Set resultNode = GetNode(xmlDocRoot, 1)
' resize array
ReDim tempString(1 To 1, 1 To resultNode.childNodes.Length)
tempString(1, 1) = GetNode(resultNode, 1).nodeTypedValue
' latitude
tempString(1, 2) = GetNode(resultNode, 2).nodeTypedValue
' longitude
tempString(1, 3) = GetNode(resultNode, 3).nodeTypedValue
GetLatLong = tempString
End Function
Sample Usage
This sample procedure will return the latitude and longitude for Astoria, NY (zip code 11103).
Dim tokenID As String
Dim results() As String
Dim result As String
Dim i As Long, j As Long
tokenID = "get your token ID from Abbreviations.com"
results = GetLocationFromZip(tokenID, "11103")
For i = LBound(results) To UBound(results)
For j = LBound(results, 2) To UBound(results, 2)
Debug.Print results(i, j)
Next j
Next i
End Sub
Don't forget to copy the helper functions found elsewhere in this article.
See more Abbreviations.com API code samples.
