我无法使用 vba 读取 openstreetmap api 的结果

Question

我在 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:        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（由 Postman 提供）返回：

<?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&amp;addressdetails=1&amp;exclude_place_ids=282751943&amp;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 与谷歌不同

xmlDoc.Load xmlhttpRequest.responseXML

但问题是我在 xmlhttpRequest 的 responseXml 中找不到 <place></place> 节点。 在chaildNodes 我只能看到xml 和searchresults。看起来 xmlDoc.Load 和 xmlhttpRequest 没有加载所有 xml 级别节点。 如何在xmlDoc.Load xmlhttpRequest.responseXML 行中获取<place></place> 节点？

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%C4%B9%E2%80%BAcielne+G%C4%B9%E2%80%9Ausk&amp;addressdetails=1&amp;format=xml&amp;accept-language=pl%2Cen-GB%3Bq%3D0.7%2Cen%3Bq%3D0.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%C5%9Bcielne+G%C5%82usk&amp;addressdetails=1&amp;exclude_place_ids=282751943&amp;format=xml&amp;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 有帮助。感谢您的快速帮助。

Answer 1

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 是否有任何内置函数可以编码网址）

我成功地尝试了这个（来源：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"