Извлечь информацию с доски MURAL, потянуть HTML-код, чтобы найти атрибуты / местоположение?

Question

Мне нужно получить информацию с доски MURAL (инструмент для дизайнерского мышления, который в значительной степени представляет собой онлайн-доску).Мне нужно вытащить следующую информацию для стикеров: https://app.mural.co/t/hanno1/m/hanno1/1488557783266/465baa38d35e95edc969a5ca9e2a8bb8b6f10310

1. Sticky Note Text
2. Атрибуты Sticky Note (Цвет, Размер, Форма)
3. Sticky Note Location
4. Ссылки на изображения (и местоположения, если это возможно)

Я создал код, который не работает.Ничего не тянет.Он практически полностью пропускает процесс открытия браузера и выхода из него.

Кроме того, как мне получить действительный HTML-код, чтобы найти атрибуты / местоположение?

Option Explicit
Public Sub GetInfo()
Dim ie As InternetExplorer, arr(), col
Set ie = New InternetExplorer
Set col = New Collection
With ie
    .Visible = True
    .navigate "https://app.mural.co/t/nextgencomms9753/m/nextgencomms9753/1536712668215/cd70107230d7f406058157a3bb8e951cedc9afc0"

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

    Dim listedItems As Object, item As Object, prices As Object, price As Object, j As Long
    Set listedItems = .document.getElementsByClassName("widget-layer-inner")
    For Each item In listedItems
        Set prices = item.getElementsByClassName("Linkify")
        ReDim arr(0 To prices.Length - 1)    'you could limit this after by redim to 0 to 0
        j = 0
        For Each price In prices
            arr(j) = price.innerText
            j = j + 1
        Next
        col.Add Array(item.getElementsByClassName("widgets-container") (0).innerText, arr)
    Next
    .Quit

    Dim item2 As Variant, rowNum As Long
    For Each item2 In col
        rowNum = rowNum + 1
        With ThisWorkbook.Worksheets("Sheet1")
            .Cells(rowNum, 1) = Replace$(Trim$(item2(0)), Chr$(10), Chr$(32))
            .Cells(rowNum, 2).Resize(1, UBound(item2(1)) + 1) = item2(1)
        End With
    Next
    End With
End Sub

Answer 1

В общем, я думаю, что по возможности следует избегать использования автоматизации IE, особенно если вы можете найти способ эмулировать этот запрос через веб-запрос.

Небольшая предыстория этого метода

---

Я отправляю два веб-запроса.Один для получения токена авторизации, а другой для получения JSON со страницы, которая заполняет виджеты на экране.Я выяснил это, изучив веб-запросы, отправляемые назад и вперед между клиентом (мной) и сервером, и эмулировал эти запросы. Описанный ниже подход довольно быстр, около 2 секунд без декодирования URL и 10 секунд с декодированием.

Вещи, которые вам понадобятся для работы

---

1. Явная ссылка установлена ​​в Microsoft XML v6.0
2. Явная ссылка установлена ​​в Microsoft Scripting Runtime
3. Проект VBA-JSON, включенный в ваш проект, получите это здесь

Код

Я выделил токен иJSON поиска в две функции.Что вы получаете от getJSON - это словарь.Этот словарь несколько вложенный, поэтому вы обращаетесь к элементам по ключу, чтобы пройти словарь вниз.Например, MyDict(property1)(childPropertyOfproperty1)(childPropertyOf...) и т. Д.

Вот код.

Option Explicit

Public Sub SubmitRequest()
    Const URL As String = "https://app.mural.co/t/hanno1/m/hanno1/1488557783266/465baa38d35e95edc969a5ca9e2a8bb8b6f10310"
    Dim returnobject    As Object
    Dim widgets         As Object
    Dim widget          As Variant
    Dim WidgetArray     As Variant
    Dim id              As String
    Dim i               As Long

    Set returnobject = getJSON(URL, getToken(URL))
    Set widgets = returnobject("widgets")
    ReDim WidgetArray(0 To 7, 0 To 10000)

    For Each widget In widgets
        'Only add if a text item, change if you like
        If returnobject("widgets")(widget)("type") = "murally.widget.TextWidget" Then
            WidgetArray(0, i) = URLDecode(returnobject("widgets")(widget)("properties")("text"))
            WidgetArray(1, i) = returnobject("widgets")(widget)("properties")("fontSize")
            WidgetArray(2, i) = returnobject("widgets")(widget)("properties")("backgroundColor")
            WidgetArray(3, i) = returnobject("widgets")(widget)("x")
            WidgetArray(4, i) = returnobject("widgets")(widget)("y")
            WidgetArray(5, i) = returnobject("widgets")(widget)("width")
            WidgetArray(6, i) = returnobject("widgets")(widget)("height")
            WidgetArray(7, i) = returnobject("widgets")(widget)("id")
            i = i + 1
        End If
    Next

    ReDim Preserve WidgetArray(0 To 7, i - 1)

    With ThisWorkbook.Worksheets("Sheet1")
        .Range("A1:H1") = Array("Text", "FontSize", "BackgroundColor", "X Position", "Y Position", "Width", "Height", "ID")
        .Range(.Cells(2, 1), .Cells(i+ 1, 8)).Value = WorksheetFunction.Transpose(WidgetArray)
    End With

End Sub

Public Function getJSON(URL As String, Token As String) As Object
    Dim baseURL         As String
    Dim getRequest      As MSXML2.XMLHTTP60
    Dim URLParts        As Variant
    Dim jsonconvert     As Object
    Dim id              As String
    dim user            as String

    URLParts = Split(URL, "/", , vbBinaryCompare)
    id = URLParts(UBound(URLParts) - 1)
    user = URLParts(UBound(URLParts) - 2)
    baseURL = Replace(Replace("https://app.mural.co/api/murals/{user}/{ID}", "{ID}", id), "{user}", user)

    Set getRequest = New MSXML2.XMLHTTP60

    With getRequest
        .Open "GET", baseURL
        .setRequestHeader "Authorization", "Bearer " & Token
        .setRequestHeader "Referer", URL
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:64.0) Gecko/20100101 Firefox/64.0"
        .send
        Set getJSON = JsonConverter.ParseJson(.responseText)
    End With

End Function

Public Function getToken(URL As String) As String
    Dim getRequest      As MSXML2.XMLHTTP60
    Dim URLParts        As Variant
    Dim position        As Long
    Dim jsonconvert     As Object
    Dim Token           As Object
    Dim State           As String
    Dim User            As String
    Dim json            As String
    Dim referer         As String
    Dim id              As String
    Dim posturl         As String

    json = "{""state"": ""{STATE}""}"
    posturl = "https://app.mural.co/api/v0/visitor/{user}.{ID}"
    referer = "https://app.mural.co/t/{user}/m/{user}/{ID}"
    URLParts = Split(URL, "/", , vbBinaryCompare)
    position = InStrRev(URL, "/")

    URL = Left$(URL, position - 1)
    State = URLParts(UBound(URLParts))
    id = URLParts(UBound(URLParts) - 1)
    User = URLParts(UBound(URLParts) - 2)

    json = Replace(json, "{STATE}", State)
    posturl = Replace(Replace(posturl, "{user}", User), "{ID}", id)
    referer = Replace(Replace(referer, "{user}", User), "{ID}", id)

    Set getRequest = New MSXML2.XMLHTTP60

    With getRequest
        .Open "POST", posturl
        .setRequestHeader "origin", "https://app.mural.co"
        .setRequestHeader "Referer", referer
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:64.0) Gecko/20100101 Firefox/64.0"
        .setRequestHeader "Content-Type", "application/json; charset=utf-8"
        .send json
        Set jsonconvert = JsonConverter.ParseJson(.responseText)
    End With

    getToken = jsonconvert("token")

End Function

' from https://stackoverflow.com/a/12804172/4839827
Public Function URLDecode(ByVal StringToDecode As String) As String
    With CreateObject("htmlfile")
        .Open
        .Write StringToDecode
        .Close
        URLDecode = .body.outerText
    End With
End Function

Вот возвращаемый результат.Существуют и другие доступные свойства, однако этот код предназначен для того, чтобы дать вам представление о том, как его вернуть.