Question

我正在尝试创建一个宏，该宏从Excel中提取一个地址列表，并将每个地址输入到Google Maps中。

然后将地址线，城市/邮政编码和国家/地区从Google地图中拉回到Excel中。

它可以工作到从Google Maps抓取信息的程度。

Sub AddressLookup() 

Application.ScreenUpdating = False

For i = 1 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    Dim IE As InternetExplorer
    Dim itemELE As Object
    Dim address As String
    Dim city As String
    Dim country As String

    Set IE = New InternetExplorer
    IE.Visible = True
    IE.navigate "https://www.google.com/maps"

    Do
        DoEvents
    Loop Until IE.readyState = READYSTATE_COMPLETE

    Dim Search As MSHTML.HTMLDocument
    Set Search = IE.document

    Search.all.q.Value = Cells(i, 1).Value

    Dim ele As MSHTML.IHTMLElement
    Dim eles As MSHTML.IHTMLElementCollection

    Set eles = Search.getElementsByTagName("button")

    For Each ele In eles

            If ele.ID = "searchbox-searchbutton" Then
                ele.click
        Else
        End If

    Next ele

    For Each itemELE In IE.document.getElementsByClassName("widget-pane widget-pane-visible")
        address = itemELE.getElementsByClassName("section-hero-header-description")(0).getElementsByTagName("h1")(0).innerText
        city = itemELE.getElementsByClassName("section-hero-header-description")(0).getElementsByTagName("h2")(0).innerText
        country = itemELE.getElementsByClassName("section-hero-header-description")(0).getElementsByTagName("h2")(1).innerText

    Next

    Cells(i, 2).Value = Trim(address)
    Cells(i, 3).Value = Trim(city)
    Cells(i, 4).Value = Trim(country)

    MsgBox country

Next

Application.ScreenUpdating = True

End Sub

Answer 1

地理编码API不再是“免费”的，尽管我实际上认为，如果您设置在一定的阈值内，则可以通过结算帐户设置免费进行抓取。作为一个新版本（地图/ API已更新），我认为期望这些API与实际地图结合使用（但不要在此引用我的意思）。

请注意以下几点：

1）在.click

之后使用适当的等待页面加载和

While ie.Busy Or ie.readyState < 4: DoEvents: Wend

2）使用.Navigate2而不是.Navigate

3）使用ID更快地进行选择。它们通常是唯一的，因此不需要循环

4）在这种情况下，需要额外的时间来允许url更新和映射到缩放等。为此，我添加了一个定时循环。我展示了一个示例，因为很明显您知道如何循环。

Option Explicit    
Public Sub GetInfo()
    Dim ie As New InternetExplorer, arr() As String, address As String, city As String, country As String
    Dim addressElement As Object, t As Date, result As String
    Const MAX_WAIT_SEC As Long = 10              '<==adjust time here
    With ie
        .Visible = True
        .Navigate2 "https://www.google.com/maps"

        While .Busy Or .readyState < 4: DoEvents: Wend

        With .document
            .querySelector("#searchboxinput").Value = "united nations headquarters,USA"
            .querySelector("#searchbox-searchbutton").Click
        End With

        While .Busy Or .readyState < 4: DoEvents: Wend

        t = Timer
        Do
            DoEvents
            On Error Resume Next
            Set addressElement = .document.querySelector(".section-info-line span.widget-pane-link")
            result = addressElement.innerText
            If Timer - t > MAX_WAIT_SEC Then Exit Do
            On Error GoTo 0
        Loop While addressElement Is Nothing
        If InStr(result, ",") > 0 Then
            arr = Split(result, ",")
            address = arr(0)
            city = arr(1)
            country = arr(2)

            With ActiveSheet
                .Cells(1, 2).Value = Trim$(address)
                .Cells(1, 3).Value = Trim$(city)
                .Cells(1, 4).Value = Trim$(country)
            End With
        End If
        Debug.Print .document.URL
        .Quit
    End With
End Sub

关于选择器-

商业地址：

.section-info-line span.widget-pane-link

以及来自OP re的反馈：住宅：

.section-hero-header div.section-hero-header-description

Answer 2

运行代码并检查Google的地址搜索结果后，我可以通过引用section-hero-header-subtitle类中的span标记来检索整个地址块“ City，Province of Postal_Code”。

在不对代码进行任何其他更改的情况下，将以下行添加到For-Each循环上方（该循环遍历小部件窗格小部件窗格可见类），然后使用F8遍历代码。

Debug.Print IE.Document.getElementsByClassName("section-hero-header-subtitle")(0).getElementsByTagName("span")(0).innerText

Answer 3

此答案将OpenStreetMap Nominatim API与VBA-Web WebRequest一起使用。

与使用Internet Explorer进行抓取相反，这是为此目的而设计的（更快，更可靠，更多信息）。也可以使用Geocode API完成此操作，但是您需要一个API密钥并跟踪成本。

如果您使用https://nominatim.openstreetmap.org/search，请尊重他们的Usage Policy，但最好自己安装。

Public Function GeocodeRequestNominatim(ByVal sAddress As String) As Dictionary
    Dim Client As New WebClient
    Client.BaseUrl = "https://nominatim.openstreetmap.org/"

    Dim Request As New WebRequest
    Dim Response As WebResponse
    Dim address As Dictionary

    With Request
        .Resource = "search/"
        .AddQuerystringParam "q", sAddress
        .AddQuerystringParam "format", "json"
        .AddQuerystringParam "polygon", "1"
        .AddQuerystringParam "addressdetails", "1"
    End With
    Set Response = Client.Execute(Request)
    If Response.StatusCode = WebStatusCode.Ok Then
       Set address = Response.Data(1)("address")
       Set GeocodeRequestNominatim = address

       'Dim Part As Variant
       'For Each Part In address.Items
       '    Debug.Print Part
       'Next Part

    Else
      Debug.Print "Error: " & Response.StatusCode & " - " & Response.Content
    End If
End Function

示例（打印国家/地区，对于其他字段，请查看提名网站上示例中返回的JSON-String）：

Debug.Print GeocodeRequestNominatim("united nations headquarters,USA")("country")

如何从Google Maps抓取地址信息？

3 个答案: