vba XMLHTTP60 從 javascript 獲取網頁標題和一些正則表達式

Question

從我一直使用的：

Url$ = "www.somewebpage.com"
Dim Http As New XMLHTTP60, worldData As Object, S$
With Http
    .Open "GET", Url, False
    .send
    S = .responseText
End With

1. 我正在尋找一種抓取網頁的方法

2. 尋找一種方法從javascript的網頁中刮取 arrays 的數據（如下所示）（請注意，此 javascript 不一定必須在節點內的第一個值和第一個值的所有示例中）我期望在下面返回什么。 我將如何開始：

   使用 CreateObject("VBScript.RegExp").Pattern = "?????" Set worldData =.Execute(S) If worldData.Count > 0 Then '在這里循環並創建/分配到 arrays End If End With

網頁上的數據：

<script type="text/javascript">
    var g_mapperData = { 
        40: { 
            '0': { 
                count: 3,
                coords: [
                    [45.2,69.9,{label:'$2$1<br><div class=q0><small>Respawn: 2min</small><br><small>Phase: 1</small><br>$3</div>',type: '0'}],
                    [45.5,69.5,{label:'$2$1<br><div class=q0><small>Respawn: 2min</small><br><small>Phase: 1</small><br>$3</div>',type: '0'}],
                    [44.8,68,{label:'$2$1<br><div class=q0><small>Respawn: 2min</small><br><small>Phase: 1</small><br>$3</div>',type: '0'}]
                ]
            }  
        },    
        12: { 
            '0': { 
                count: 1,
                coords: [
                    [48.4,86.61,{label:'$2$1<br><div class=q0><small>Respawn: 2min</small><br><small>Phase: 1</small><br>$3</div>',type: '0'}]
                ]
            }  
        },    
        3524: { 
            '0': { 
                count: 2,
                coords: [
                    [48.2,70.9,{label:'$2$1<br><div class=q0><small>Respawn: 2min</small><br><small>Phase: 1</small><br>$3</div>',type: '0'}],
                    [46.1,70.7,{label:'$2$1<br><div class=q0><small>Respawn: 2min</small><br><small>Phase: 1</small><br>$3</div>',type: '0'}]
                ]
            }  
        }   
    };
</script>

arrays 的預期結果：

MapID = {40, 12, 3524}
Xcoord = {45.2, 48.4, 48.2}
Ycoord = {69.9, 86.61, 70.9}

每個數組總是應該具有相同長度的值，因為每個“MapID”至少有一個 X/Y 記錄（可能更多，甚至多達數百個），而且 MapID 可能只有一個甚至數百個。

感謝巫師的魔法

Answer 1

謝謝，它工作得很好......我稍微調整了一下以達到我的目的：

Sub test()

Dim Http As New XMLHTTP60, s As String, re As VBScript_RegExp_55.RegExp
Dim matches As VBScript_RegExp_55.MatchCollection, json As Object
Dim key As Variant, dict As Scripting.Dictionary
Dim mapId(), xCoord(), yCoord(), i As Long
Dim mapId_element As Variant

For row = 2 To 2 'ThisWorkbook.Worksheets("N-Scrap").UsedRange.Rows.Count
    If IsEmpty(ThisWorkbook.Worksheets("N-Scrap").Cells(row, 2)) Then

        'World Data
        Url$ = "www.somewebpage.com/?item=" & ThisWorkbook.ActiveSheet.Cells(row, 1).Value2
        With Http
            .Open "GET", Url, False
            .send
            s = .responseText
        End With
        With CreateObject("VBScript.RegExp")
            .Pattern = "g_mapperData = (\{[\s\S]+?\});"
            Set matches = .Execute(s)
            If matches.Count > 0 Then

                JsonConverter.JsonOptions.AllowUnquotedKeys = True

                On Error GoTo errhand

                Set json = JsonConverter.ParseJson(matches.Item(0).SubMatches(0))
                Set dict = New Scripting.Dictionary      'to be a dict of collections

                For Each key In json.Keys()
                    dict.Add key, json(key)("0")("coords")(1) 'assumes unique keys
                Next

                'MapID = {40, 12, 3524}, Xcoord = {45.2, 48.4, 48.2}, Ycoord = {69.9, 86.61, 70.9}

                mapId = dict.Keys

                ReDim xCoord(0 To UBound(mapId))
                ReDim yCoord(0 To UBound(mapId))

                For Each key In dict
                    xCoord(i) = dict(key)(1)
                    yCoord(i) = dict(key)(2)
                    i = i + 1
                Next
                'Stop
            End If
        End With

    End If

    'Clear for next loop
    Set matches = Nothing
    Set json = Nothing
    Set dict = Nothing
    Erase mapId
    Erase xCoord
    Erase yCoord
    i = Empty

errhand:
If Err.Number > 0 Then Debug.Print Err.Number, Err.Description

Next row

End Sub

所以我還有一個問題。 從最初的帖子開始，這個腳本收集價值的“簡單”是什么？ 我知道的方式絕對不容易，而且會慢很多......

Answer 2

如果結構和鍵是常規的，那么您可以使用正則表達式來獲取父g_mapper_Data var 並使用jsonconverter.bas進行解析； 確保將 unquoted keys 標志設置為True 。 在這里，我正在讀取單元格 A1 中的.responseText 。 您會特別想開發錯誤處理。 這有點粗糙和准備就緒，並且有很多假設。

注意

在 VBA JSON {} 是一個字典，您可以循環或通過鍵訪問； [] 表示你可以 For Each 的集合。 json 是嵌套的。 您需要熟悉這些概念。

對於 json 解析，我使用jsonconverter.bas 。 從那里下載原始代碼並添加到名為 JsonConverter 的標准模塊中。 然后，您需要 go VBE > Tools > References > Add reference to Microsoft Scripting Runtime 。 從復制的代碼中刪除頂部的 Attribute 行（這是用於直接導入 .bas 的情況）。

Option Explicit

Public Sub GetInfoFromScriptTag()
    'required reference Microsoft VBScript Regular Expressions; Microsoft Scripting Runtime
    Dim s As String, re As VBScript_RegExp_55.RegExp

    s = ActiveSheet.Range("A1").Value
    Set re = New VBScript_RegExp_55.RegExp

    re.Pattern = "g_mapperData = (\{[\s\S]+?\});"

    Dim matches As VBScript_RegExp_55.MatchCollection, json As Object

    Set matches = re.Execute(s)

    If matches.Count Then

        JsonConverter.JsonOptions.AllowUnquotedKeys = True

        On Error GoTo errhand

        Set json = JsonConverter.ParseJson(matches.item(0).SubMatches(0))

        Dim key As Variant, dict As Scripting.Dictionary

        Set dict = New Scripting.Dictionary      'to be a dict of collections

        For Each key In json.keys()
            dict.Add key, json(key)("0")("coords")(1) 'assumes unique keys
        Next

        'MapID = {40, 12, 3524}, Xcoord = {45.2, 48.4, 48.2}, Ycoord = {69.9, 86.61, 70.9}

        Dim mapId(), xCoord(), yCoord(), i As Long

        mapId = dict.keys

        ReDim xCoord(0 To UBound(mapId))
        ReDim yCoord(0 To UBound(mapId))

        For Each key In dict
            xCoord(i) = dict(key)(1)
            yCoord(i) = dict(key)(2)
            i = i + 1
        Next
        Stop
    End If
    Exit Sub
errhand:
    Debug.Print Err.Number, Err.Description
End Sub

---

Output：

---

正則表達式：