Как очистить адресную информацию от Google Maps?

Question

Я пытаюсь создать макрос, который извлекает список адресов из Excel и вводит каждый из них в Карты Google.

Затем он возвращает строку адреса, город / почтовый индекс и страну из Карт Google обратно вExcel.

Работает до того момента, когда извлекает информацию из Карт Google.

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) Используйте идентификаторы как можно быстрее для выбора.Как правило, они уникальны, поэтому не требуется зацикливание

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: residential:

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

Answer 2

В этом ответе используется OpenStreetMap Nominatim API с VBA-Web WebRequest.

В отличие от очистки с помощью Internet Explorer это разработано для этой цели (быстрее, надежнее, больше информации).Это можно сделать и с помощью Geocode API , но вам нужен API-ключ и отслеживание стоимости.

Если вы используете https://nominatim.openstreetmap.org/search, соблюдайте их Политика использования , но лучше иметь собственную установку.

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 в примере на веб-сайте номинации):

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

Answer 3

После запуска вашего кода и проверки результатов поиска адресов в Google я смог извлечь весь адресный блок 'City, Province Postal_Code', сославшись на тег span внутри класса section-hero-header-subtitle.

Не внося никаких других изменений в ваш код, добавьте следующую строку над циклом For-Each (который проходит через видимый класс widget-pane widget-pane) и переходите по коду, используя F8.

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