Question

我必须从MURAL板（设计思维工具，这几乎是一个在线白板）中获取信息。我需要将以下信息用于粘贴： https://app.mural.co/t/hanno1/m/hanno1/1488557783266/465baa38d35e95edc969a5ca9e2a8bb8b6f10310

粘滞便笺文本
粘滞便笺属性（颜色，大小，形状）
便笺位置
图像链接（以及位置）（如果可能）

我创建的代码无法正常工作。什么都没有被拉。从打开到退出浏览器几乎都是直接跳过。

我也该如何提取实际的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自动化，尤其是当您可以找到一种通过Web请求模拟此请求的方法时。

有关此方法的一些背景知识

我正在提交两个Web请求。一种是获取授权令牌，另一种是从填充屏幕上小部件的页面获取JSON。我通过研究在客户端（me）和服务器之间来回发送的Web请求并模拟了这些请求来弄清了这一点，下面概述的方法非常快，没有URL解码大约需要2秒，有解码需要10秒。 / p>

此功能需要您完成的工作

显式引用设置为Microsoft XML v6.0
显式引用设置为Microsoft脚本运行时
项目中包含的VBA-JSON项目，请获取here

代码

我将令牌和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

这是返回的输出。还有其他可用的属性，但是此代码仅是为了让您了解如何撤消该属性。

从MURAL板上提取信息，提取HTML代码以查找属性/位置？

1 个答案: