I have a database of addresses in MSAccess. I would like to fill in the gps coordinates (latitude and longitude) automatically. I found a VBA script that retrieves data from google, but I would like to rewrite this script to retrieve data from openstreetmap. the script I am modifying :
Public Function GetCoordinates(address As String) As String
'Written By: Christos Samaras
'Date: 12/06/2014
'Last Updated: 16/02/2020
'E-mail: [email protected]
'Site: https://www.myengineeringworld.net
'-----------------------------------------------------------------------------------------------------
'Declaring the necessary variables.
Dim apiKey As String
Dim xmlhttpRequest As Object
Dim xmlDoc As Object
Dim xmlStatusNode As Object
Dim xmlLatitudeNode As Object
Dim xmLongitudeNode As Object
'Set your API key in this variable. Check this link for more info:
'https://www.myengineeringworld.net/2018/02/how-to-get-free-google-api-key.html
'Here is the ONLY place in the code where you have to put your API key.
apiKey = "XXXXXXXXXXXXXXXXXXXXXXXXXX"
'Check that an API key has been provided.
If apiKey = vbNullString Or apiKey = "The API Key" Then
GetCoordinates = "Empty or invalid API Key"
Exit Function
End If
'Generic error handling.
On Error GoTo errorHandler
'Create the request object and check if it was created successfully.
Set xmlhttpRequest = CreateObject("MSXML2.ServerXMLHTTP")
If xmlhttpRequest Is Nothing Then
GetCoordinates = "Cannot create the request object"
Exit Function
End If
'Create the request based on Google Geocoding API. Parameters (from Google page):
'- Address: The address that you want to geocode.
'Note: The EncodeURL function was added to allow users from Greece, Poland, Germany, France and other countries
'geocode address from their home countries without a problem. The particular function (EncodeURL),
'returns a URL-encoded string without the special characters.
'This function, however, was introduced in Excel 2013, so it will NOT work in older Excel versions.
'xmlhttpRequest.Open "GET", "https://maps.googleapis.com/maps/api/geocode/xml?" _
& "&address=" & address & "&key=" & apiKey, False
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & Replace(address, " ", " ") & "&format=xml&polygon=1&addressdetails=1"
'An alternative way, without the EncodeURL function, will be this:
'xmlhttpRequest.Open "GET", "https://maps.googleapis.com/maps/api/geocode/xml?" & "&address=" & Address & "&key=" & ApiKey, False
'Send the request to the Google server.
xmlhttpRequest.send
'Create the DOM document object and check if it was created successfully.
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
If xmlDoc Is Nothing Then
GetCoordinates = "Cannot create the DOM document object"
Exit Function
End If
'Read the XML results from the request.
xmlDoc.LoadXML xmlhttpRequest.responseText
'Get the value from the status node.
Set xmlStatusNode = xmlDoc.SelectSingleNode("//statusText")
'Based on the status node result, proceed accordingly.
Select Case UCase(xmlStatusNode.Text)
Case "OK" 'The API request was successful.
'At least one result was returned.
'Get the latitude and longitude node values of the first result.
Set xmlLatitudeNode = xmlDoc.SelectSingleNode("//result/geometry/location/lat")
Set xmLongitudeNode = xmlDoc.SelectSingleNode("//result/geometry/location/lng")
'Return the coordinates as a string (latitude, longitude).
GetCoordinates = xmlLatitudeNode.Text & ", " & xmLongitudeNode.Text
Case "ZERO_RESULTS" 'The geocode was successful but returned no results.
GetCoordinates = "The address probably do not exist"
Case "OVER_DAILY_LIMIT" 'Indicates any of the following:
'- The API key is missing or invalid.
'- Billing has not been enabled on your account.
'- A self-imposed usage cap has been exceeded.
'- The provided method of payment is no longer valid
' (for example, a credit card has expired).
GetCoordinates = "Billing or payment problem"
Case "OVER_QUERY_LIMIT" 'The requestor has exceeded the quota limit.
GetCoordinates = "Quota limit exceeded"
Case "REQUEST_DENIED" 'The API did not complete the request.
GetCoordinates = "Server denied the request"
Case "INVALID_REQUEST" 'The API request is empty or is malformed.
GetCoordinates = "Request was empty or malformed"
Case "UNKNOWN_ERROR" 'The request could not be processed due to a server error.
GetCoordinates = "Unknown error"
Case Else 'Just in case...
GetCoordinates = "Error"
End Select
'Release the objects before exiting (or in case of error).
errorHandler:
Set xmlStatusNode = Nothing
Set xmlLatitudeNode = Nothing
Set xmLongitudeNode = Nothing
Set xmlDoc = Nothing
Set xmlhttpRequest = Nothing
End Function
Everything goes fine until the response is read in xml in the line:
xmlDoc.LoadXML xmlhttpRequest.responseText
API OpenStreetMap (by Postman) returns:
<?xml version="1.0" encoding="UTF-8" ?>
<searchresults timestamp='Tue, 30 Nov 21 23:27:43 0000' attribution='Data © OpenStreetMap contributors, ODbL 1.0. http://www.openstreetmap.org/copyright' querystring='Abramowice Kościelne Głusk' exclude_place_ids='282751943' more_url='https://nominatim.openstreetmap.org/search/?q=Abramowice Kościelne Głusk&addressdetails=1&exclude_place_ids=282751943&format=xml'>
<place place_id='282751943' osm_type='relation' osm_id='6187770' place_rank='16' address_rank='16' boundingbox="51.1900199,51.1955316,22.6211673,22.6355145" lat='51.1905395' lon='22.6282202' display_name='Abramowice Kościelne, gmina Głusk, powiat lubelski, województwo lubelskie, Polska' class='boundary' type='administrative' importance='0.59025964622406' icon='https://nominatim.openstreetmap.org/ui/mapicons//poi_boundary_administrative.p.20.png'>
<village>Abramowice Kościelne</village>
<municipality>gmina Głusk</municipality>
<county>powiat lubelski</county>
<state>województwo lubelskie</state>
<country>Polska</country>
<country_code>pl</country_code>
</place>
</searchresults>
Beacuse the response api is different from google I am loading
xmlDoc.Load xmlhttpRequest.responseXML
But the problem is that I can't find <place></place> node in responseXml from xmlhttpRequest.
In chaildNodes i can see only xml and searchresults. It looks like xmlDoc.Load and xmlhttpRequest did not load all xml levels node.
How obtain <place></place> node in line xmlDoc.Load xmlhttpRequest.responseXML?
responseText returns that:
<?xml version="1.0" encoding="UTF-8" ?>
<searchresults timestamp='Wed, 01 Dec 21 06:38:10 0000' attribution='Data © OpenStreetMap contributors, ODbL 1.0. http://www.openstreetmap.org/copyright' querystring='Abramowice KoĹ›cielne GĹ‚usk' more_url='https://nominatim.openstreetmap.org/search/?q=Abramowice KoĹ›cielne GĹ‚usk&addressdetails=1&format=xml&accept-language=pl,en-GB;q=0.7,en;q=0.3'>
</searchresults>
The problem was in the wrong query. I called the address "Abramowice Kościelne gm. Głusk" but api does not understand what it means gm. (commune in Polish) and therefore could not return eny result. When calling Abramowice Kościelne Głusk, I get the correct result in responseText.
<?xml version="1.0" encoding="UTF-8" ?>
<searchresults timestamp='Wed, 01 Dec 21 09:51:58 0000' attribution='Data © OpenStreetMap contributors, ODbL 1.0. http://www.openstreetmap.org/copyright' querystring='Abramowice Kościelne Głusk' exclude_place_ids='282751943' more_url='https://nominatim.openstreetmap.org/search/?q=Abramowice Kościelne Głusk&addressdetails=1&exclude_place_ids=282751943&format=xml&accept-language=pl,en-GB;q=0.7,en;q=0.3'>
<place place_id='282751943' osm_type='relation' osm_id='6187770' place_rank='16' address_rank='16' boundingbox="51.1900199,51.1955316,22.6211673,22.6355145" lat='51.1905395' lon='22.6282202' display_name='Abramowice Kościelne, gmina Głusk, powiat lubelski, województwo lubelskie, Polska' class='boundary' type='administrative' importance='0.59025964622406' icon='https://nominatim.openstreetmap.org/ui/mapicons//poi_boundary_administrative.p.20.png'>
<village>Abramowice Kościelne</village><municipality>gmina Głusk</municipality><county>powiat lubelski</county><state>województwo lubelskie</state><country>Polska</country><country_code>pl</country_code></place></searchresults>
I think additional function URLEncode help to. Thx for fast help.
Before it was:
Set xmlLatitudeNode = xmlDoc.SelectSingleNode("//result/geometry/location/lat")
Set xmLongitudeNode = xmlDoc.SelectSingleNode("//result/geometry/location/lng")
How it will be in my case?
CodePudding user response：
Most likely the address passed in address is not translated correctly with just Replace function so you should use Excel built-in function EncodeURL to translate it correctly.
So change this line:
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & Replace(address, " ", " ") & "&format=xml&polygon=1&addressdetails=1"
To this:
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & WorksheetFunction.EncodeURL(address) & "&format=xml&polygon=1&addressdetails=1"
EncodeURL function is only available from Excel 2013 so if you are running this from Access - You will probably need to use a function to encode the URL (I'm not sure if Access have any built-in function that encode URL)
I tried this with success (Source: How can I URL encode a string in Excel VBA?) so paste the function below to your module as well:
Public Function URLEncode( _
ByVal StringVal As String, _
Optional SpaceAsPlus As Boolean = False _
) As String
Dim bytes() As Byte, b As Byte, i As Integer, space As String
If SpaceAsPlus Then space = " " Else space = " "
If Len(StringVal) > 0 Then
With New ADODB.Stream
.Mode = adModeReadWrite
.Type = adTypeText
.Charset = "UTF-8"
.Open
.WriteText StringVal
.Position = 0
.Type = adTypeBinary
.Position = 3 ' skip BOM
bytes = .Read
End With
ReDim result(UBound(bytes)) As String
For i = UBound(bytes) To 0 Step -1
b = bytes(i)
Select Case b
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Chr(b)
Case 32
result(i) = space
Case 0 To 15
result(i) = "%0" & Hex(b)
Case Else
result(i) = "%" & Hex(b)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
And change the line above to:
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & URLEncode(address) & "&format=xml&polygon=1&addressdetails=1"