使用带有 JSON 响应的 VBA 请求

Question

我正在通过VBA-WEB、VBA-REST等进行编码，参考VBA和编码相关的主页。

https://www.marketscreener.com

我认为在登录并登录我的主页后我应该有一个 COOKIE 值。

https://www.marketscreener.com/stock-exchange/shares/North-America-8/United-States-12/

我想将下图中的数据值导入Excel。

属于类别[公司/价格/资本化/1st Jan% Sector]的公司列表

我一直在努力使用 VBA-WEB、VBA-REST..BUT.. 0 # - #

只显示这些结果。我不知道出了什么问题，所以我收到了一个请求。 这是一个只有VBA学得很少的级别，因为它不知道，因为它是一个编码初学者。

Sheets (1) .Cells (2, 1) .Value 如下。

{"Req":{"TRBC":0,"TRBC_chain":[""],"aSectors":[{},{},{},{},{}],"markets":[ 12],"capi_min":0,"capi_max":10,"liqu_min":0,"liqu_max":10,"tri":[0,1,2,3,4,5],"ord":[ "N","N","N","D","N","N"],"special_option_news":"","special_option_date":"","special_dynamic":"","special_partner": "","re​​sult_mode":7,"crit":[],"page":2},"bJSON":"true"}

参数如下。

https://www.marketscreener.com/outils/mods_a/moteurs_results.php?ResultMode=7&model=3&

我不知道出了什么问题。我是 VBA 的初学者，非常感谢您的具体修改。

---

Dim MyntraClient As New RestClient
MyntraClient.BaseUrl = "https://www.marketscreener.com/"

'With inline JSON
Dim json As String

 json = Sheets (1) .Cells (2, 1) .Value

Dim Response As RestResponse

Set Response = MyntraClient.PostJSON ("stock-exchange / shares / North-America-8 / United States-12 /

'It's no fun creating json string by hand, instead of create it via Dictionary / Collection / Array

Dim SearchParameters As New Dictionary

SearchParameters.Add "TRBC", 0
SearchParameters.Add "TRBC_chain", Array ("")
SearchParameters.Add "aSectors", Array ("{}", "{}", "{}", "{}", "{}"
SearchParameters.Add "markets", Array (12)
SearchParameters.Add "capi_min", 0
SearchParameters.Add "capi_max", 10
SearchParameters.Add "liqu_min", 0
SearchParameters.Add "liqu_max", 10
SearchParameters.Add "tri", Array (0, 1, 2, 3, 4, 5) '"[0,1,2,3,4,5]"
SearchParameters.Add "ord", Array ("N", "N", "N", "D", "N" N "", "" D "", "" N "", "" N ""] "
SearchParameters.Add "special_option_news", "" ""
SearchParameters.Add "special_option_date", "" ""
SearchParameters.Add "special_dynamic", "" ""
SearchParameters.Add "special_partner", "" ""
SearchParameters.Add "result_mode", 7
SearchParameters.Add "crit", Array ()
SearchParameters.Add "page", 1
SearchParameters.Add "bJSON", True

Set Response = MyntraClient.PostJSON ("outils / mods_a / moteurs_results.php? ResultMode = 7 & model = 3 &", Array (SearchParameters))

'Check status, received content, or do something with the data directly
Debug.Print Response.StatusCode
Debug.Print Response.Content
Sheets (1) .Cells (3, 1) .Value = Response.StatusCode
Sheets (1) .Cells (4, 1) .Value = Response.Content

---

enter image description here

Answer 1

在从登录页面 (page2) 进行页面选择时，我使用 fiddler 来监控网络流量。我使用该信息生成了一个 XMLHTTP Post 请求。

我将以下内容放在工作表 1 单元格 A1 中，以节省代码中的转义字符。

{"TRBC":0,"TRBC_chain":[""],"aSectors":[{},{},{},{},{}],"markets":[12],"capi_min":0,"capi_max":10,"liqu_min":0,"liqu_max":10,"tri":[0,1,2,3,4,5],"ord":["N","N","N","D","N","N"],"special_option_news":"","special_option_date":"","special_dynamic":"","special_partner":"","result_mode":7,"crit":[],"page":2}

然后使用以下代码：

Option Explicit
Public Sub GetTable()
    Dim sResponse As String, html As New HTMLDocument, hTable As HTMLTable
    Dim http As New MSXML2.XMLHTTP60, body As String, ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    body = "Req=" & ws.Range("A1")
    body = body & "&bJSON=true"

    With http
        .Open "POST", "https://www.marketscreener.com/outils/mods_a/moteurs_results.php?ResultMode=7&model=3&undefined, False"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send body
        sResponse = StrConv(.responseBody, vbUnicode)
    End With

    With html
        .body.innerHTML = sResponse
        Set hTable = .getElementById("ZBS_restab_2b")
    End With
    WriteTable hTable, 2, ws
End Sub

Public Sub WriteTable(ByVal hTable As HTMLTable, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)
    If ws Is Nothing Then Set ws = ActiveSheet
    Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
    r = startRow
    With ws
        Set tRow = hTable.getElementsByTagName("tr")
        For Each tr In tRow
            r = r + 1
            Set tCell = tr.getElementsByTagName("td")
            c = 1
            For Each td In tCell
                .Cells(r, c).Value = td.innerText
                c = c + 1
            Next td
        Next tr
    End With
End Sub

---

示例结果：

---

参考资料（VBE > 工具 > 参考资料）：

1. Microsoft HTML 对象库
2. Microsoft XML, V6.0 '适用于我的 Excel 2016 版本