我在 MSAccess 中有一個地址資料庫。我想自動填寫gps坐標（緯度和經度）。我找到了一個從谷歌檢索資料的 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: [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
一切正常，直到在 xml 中讀取回應：
xmlDoc.LoadXML xmlhttpRequest.responseText
API OpenStreetMap（由郵遞員提供）回傳：
<?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>
因為回應 api 與我正在加載的 google 不同
xmlDoc.Load xmlhttpRequest.responseXML
但問題是我<place></place>在 xmlhttpRequest 的 responseXml 中找不到節點。在 chaildNodes 中，我只能看到xml和searchresults。它看起來像xmlDoc.Load和xmlhttpRequest未裝入所有XML層次節點。如何在線獲取<place></place>節點xmlDoc.Load xmlhttpRequest.responseXML？
responseText 回傳：
<?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>
問題出在錯誤的查詢中。我將地址稱為“Abramowice Ko?cielne gm. G?usk”，但 api 不明白 gm 是什么意思。（波蘭語公社）因此無法回傳任何結果。在呼叫 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ś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>
我認為附加函式 URLEncode 有幫助。感謝快速幫助。
uj5u.com熱心網友回復：
很可能傳入的地址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）
我成功地嘗試了這個（來源：如何在 Excel VBA 中對字串進行 URL 編碼？）所以也將下面的函式粘貼到您的模塊中：
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
并將上面的行更改為：
xmlhttpRequest.Open "GET", "http://nominatim.openstreetmap.org/search?q=" & URLEncode(address) & "&format=xml&polygon=1&addressdetails=1"
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/370746.html