Извлечение координат маркера из встроенной карты Google

Question

Довольно новичок в этом, так что терпите меня. Мне нужно извлечь координаты маркера из встроенной карты Google - пример ссылки http://www.picknpay.co.za/store-search и я хочу извлечь все позиции маркеров, сгенерированные на карте при поиске. Рассматривал возможность использования таких сервисов, как ParseHub, но перед тем, как пойти по этому пути, я решил попробовать через SO/ себя.

Должен быть более простой способ найти координаты для маркеров, хранящихся на карте, чем вручную просматривать их все и искать их координаты по отдельности?

Answer 1

Исходный HTML-код веб-страницы по предоставленной ссылке http://www.picknpay.co.za/store-search не содержит необходимых данных, он использует AJAX. На веб-сайте http://www.picknpay.co.za/ есть API-интерфейс sorta. Ответ возвращается в формате JSON. Перейдите на страницу, например, в Chrome, затем откройте окно "Инструменты разработчика" (F12), вкладку "Сеть", перезагрузите (F5) страницу и изучите зарегистрированные XHR. Наиболее релевантными данными являются строки JSON, возвращаемые URL:

http://www.picknpay.co.za/picknpay/json/picknpay/en/modules/store_finder/findStores.json

Вы можете использовать приведенный ниже код VBA для получения информации, как описано выше. Импортируйте модуль JSON.bas в проект VBA для обработки JSON.

Option Explicit

Sub Scrape_picknpay_co_za()

    Dim sResponse As String
    Dim sState As String
    Dim vJSON As Variant
    Dim aRows() As Variant
    Dim aHeader() As Variant

    ' Retrieve JSON data
    XmlHttpRequest "POST", "http://www.picknpay.co.za/picknpay/json/picknpay/en/modules/store_finder/findStores.json", "", "", "", sResponse
    ' Parse JSON response
    JSON.Parse sResponse, vJSON, sState
    If sState <> "Array" Then
        MsgBox "Invalid JSON response"
        Exit Sub
    End If
    ' Convert result to arrays for output
    JSON.ToArray vJSON, aRows, aHeader
    ' Output
    With ThisWorkbook.Sheets(1)
        OutputArray .Cells(1, 1), aHeader
        Output2DArray .Cells(2, 1), aRows
        .Columns.AutoFit
    End With

    MsgBox "Completed"

End Sub

Sub XmlHttpRequest(sMethod As String, sUrl As String, arrSetHeaders, sFormData, sRespHeaders As String, sContent As String)

    Dim arrHeader

    'With CreateObject("Msxml2.ServerXMLHTTP")
    '    .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
    With CreateObject("MSXML2.XMLHTTP")
        .Open sMethod, sUrl, False
        If IsArray(arrSetHeaders) Then
            For Each arrHeader In arrSetHeaders
                .SetRequestHeader arrHeader(0), arrHeader(1)
            Next
        End If
        .send sFormData
        sRespHeaders = .GetAllResponseHeaders
        sContent = .responseText
    End With

End Sub

Sub OutputArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Sub Output2DArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize( _
                UBound(aCells, 1) - LBound(aCells, 1) + 1, _
                UBound(aCells, 2) - LBound(aCells, 2) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Вывод для меня выглядит следующим образом:

Кстати, тот же подход применяется в следующих ответах: 1, 2, 3, 4, 5, 6, 7, 8 и 9.