我无法使用 vba 读取 openstreetmap api 的结果
I can't read the results of the openstreetmap api with vba
我在 MSAccess 中有一个地址数据库。我想自动填写 gps 坐标（纬度和经度）。我找到了一个从 google 检索数据的 VBA 脚本，但我想重写这个脚本以从 openstreetmap 检索数据。
我正在修改的脚本：
Public Function GetCoordinates(address As String) As String
'Written By: Christos Samaras
'Date: 12/06/2014
'Last Updated: 16/02/2020
'E-mail: xristos.samaras@gmail.com
'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
一切正常，直到在 xml 行中读取响应：
xmlDoc.LoadXML xmlhttpRequest.responseText
API OpenStreetMap（邮递员）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%C5%9Bcielne+G%C5%82usk&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>
因为响应 api 不同于 google 我正在加载
xmlDoc.Load xmlhttpRequest.responseXML
但问题是我无法在 xmlhttpRequest 的 responseXml 中找到 <place></place> 节点。
在 chailNodes 中，我只能看到 xml 和 searchresults。看起来 xmlDoc.Load 和 xmlhttpRequest 没有加载所有 xml 级别节点。
如何获取xmlDoc.Load xmlhttpRequest.responseXML行的<place></place>节点？
responseText return是：
<?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%C4%B9%E2%80%BAcielne+G%C4%B9%E2%80%9Ausk&addressdetails=1&format=xml&accept-language=pl%2Cen-GB%3Bq%3D0.7%2Cen%3Bq%3D0.3'>
</searchresults>
问题出在错误的查询上。
我将地址命名为“Abramowice Kościelne gm. Głusk”，但是
api不明白gm是什么意思。 （波兰语公社）因此无法 return eny 结果。调用 Abramowice Kościelne Głusk 时，我在 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%C5%9Bcielne+G%C5%82usk&addressdetails=1&exclude_place_ids=282751943&format=xml&accept-language=pl%2Cen-GB%3Bq%3D0.7%2Cen%3Bq%3D0.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>
我认为附加函数 URLEncode 有帮助。感谢快速帮助。
很可能 address 中传递的地址仅使用 Replace 函数无法正确翻译，因此您应该使用 Excel 内置函数 EncodeURL 来正确翻译它.
因此更改此行：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & Replace(address, " ", "+") & "&format=xml&polygon=1&addressdetails=1"
为此：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & WorksheetFunction.EncodeURL(address) & "&format=xml&polygon=1&addressdetails=1"
EncodeURL 函数仅从 Excel 2013 起可用，因此如果您是 运行 来自 Access 的此函数 - 您可能需要使用一个函数来编码 URL （我不确定 Access 是否有任何编码 URL 的内置函数）
我成功地尝试了这个（来源：How can I URL encode a string in Excel VBA?）所以也将下面的函数粘贴到您的模块中：
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 = "%20"
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
并将上面的行更改为：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & URLEncode(address) & "&format=xml&polygon=1&addressdetails=1"
我在 MSAccess 中有一个地址数据库。我想自动填写 gps 坐标（纬度和经度）。我找到了一个从 google 检索数据的 VBA 脚本，但我想重写这个脚本以从 openstreetmap 检索数据。 我正在修改的脚本：
Public Function GetCoordinates(address As String) As String
'Written By: Christos Samaras
'Date: 12/06/2014
'Last Updated: 16/02/2020
'E-mail: xristos.samaras@gmail.com
'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
一切正常，直到在 xml 行中读取响应：
xmlDoc.LoadXML xmlhttpRequest.responseText
API OpenStreetMap（邮递员）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%C5%9Bcielne+G%C5%82usk&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>
因为响应 api 不同于 google 我正在加载
xmlDoc.Load xmlhttpRequest.responseXML
但问题是我无法在 xmlhttpRequest 的 responseXml 中找到 <place></place> 节点。
在 chailNodes 中，我只能看到 xml 和 searchresults。看起来 xmlDoc.Load 和 xmlhttpRequest 没有加载所有 xml 级别节点。
如何获取xmlDoc.Load xmlhttpRequest.responseXML行的<place></place>节点？
responseText return是：
<?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%C4%B9%E2%80%BAcielne+G%C4%B9%E2%80%9Ausk&addressdetails=1&format=xml&accept-language=pl%2Cen-GB%3Bq%3D0.7%2Cen%3Bq%3D0.3'>
</searchresults>
问题出在错误的查询上。 我将地址命名为“Abramowice Kościelne gm. Głusk”，但是 api不明白gm是什么意思。 （波兰语公社）因此无法 return eny 结果。调用 Abramowice Kościelne Głusk 时，我在 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%C5%9Bcielne+G%C5%82usk&addressdetails=1&exclude_place_ids=282751943&format=xml&accept-language=pl%2Cen-GB%3Bq%3D0.7%2Cen%3Bq%3D0.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>
我认为附加函数 URLEncode 有帮助。感谢快速帮助。
很可能 address 中传递的地址仅使用 Replace 函数无法正确翻译，因此您应该使用 Excel 内置函数 EncodeURL 来正确翻译它.
因此更改此行：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & Replace(address, " ", "+") & "&format=xml&polygon=1&addressdetails=1"
为此：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & WorksheetFunction.EncodeURL(address) & "&format=xml&polygon=1&addressdetails=1"
EncodeURL 函数仅从 Excel 2013 起可用，因此如果您是 运行 来自 Access 的此函数 - 您可能需要使用一个函数来编码 URL （我不确定 Access 是否有任何编码 URL 的内置函数）
我成功地尝试了这个（来源：How can I URL encode a string in Excel VBA?）所以也将下面的函数粘贴到您的模块中：
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 = "%20"
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
并将上面的行更改为：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & URLEncode(address) & "&format=xml&polygon=1&addressdetails=1"