json - 使用带有 JSON 响应的 VBA 请求
问题描述
我是通过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":"", "result_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
解决方案
从登录页面(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 > 工具 > 参考资料):
- Microsoft HTML 对象库
- Microsoft XML, V6.0 '对于我的 Excel 2016 版本
推荐阅读
- perl - 在字符串中查找单词
- git - 恢复先前提交的版本,包括 Excel 文件
- mysql - 计算行中的值也在前一行中的行
- vpn - 通过 VPN 访问 fritzbox 界面并使用 samba 共享
- vue.js - 参数化 v-for 指令
- javascript - 车把快递加载动态图片
- amazon-web-services - Github Webhook 被 AWS CodeBuild 拒绝
- javascript - 局部变量与数据。性能损失巨大
- python - 如何在 Chromedriver 79 中将“useAutomationExtension”设置为 false
- php - 通过直接 URL 访问在 laravel 的会话中保持语言环境