解析www.niftyindices.com的JSON时VBA JsonConverter报错求助

此前使用以下VBA代码从niftyindices.com抓取历史数据，现在JsonConverter出现解析错误（错误提示为Run-time error '5': Invalid procedure call or argument），无法排查原因，附上代码请求帮助解决：

Option Explicit

Sub nse()
Dim req As New MSXML2.XMLHTTP60
Dim url As String, defaultPayload As String, requestPayload As String, results() As String
Dim payloadJSON As Object, responseJSON As Object, item As Object
Dim startD As Date, endD As Date
Dim key As Variant
Dim i As Long, j As Long
Dim rng As Range

startD = "01/02/2020" 'Start date
endD = "29/02/2020" 'end date
url = "https://www.niftyindices.com/Backpage.aspx/getHistoricaldatatabletoString"
defaultPayload = "{'name':'NIFTY 50','startDate':'','endDate':''}"
Set rng = ThisWorkbook.Worksheets("NSE").Range("A2") 'Output worksheet name.


Set payloadJSON = JsonConverter.ParseJson(defaultPayload)
payloadJSON("startDate") = Day(startD) & "-" & MonthName(Month(startD), True) & "-" & Year(startD) '01-Feb-2020
payloadJSON("endDate") = Day(endD) & "-" & MonthName(Month(endD), True) & "-" & Year(endD) '29-Feb-2020
requestPayload = JsonConverter.ConvertToJson(payloadJSON)

With req
    .Open "POST", url, False
    .setRequestHeader "Content-Type", "application/json; charset=UTF-8"
    .setRequestHeader "X-Requested-With", "XMLHttpRequest"
    .send requestPayload
    Set responseJSON = JsonConverter.ParseJson(.responseText)
End With
Debug.Print responseJSON("d")
Set responseJSON = JsonConverter.ParseJson(responseJSON("d"))
ReDim results(1 To responseJSON.Count, 1 To 7)
i = 0
For Each item In responseJSON
    i = i + 1
    j = 0
    For Each key In item
        j = j + 1
        results(i, j) = item(key)
    Next key
Next item
rng.Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

可能的修复方向及优化代码 #

1. 补充必要请求头：网站可能新增反爬校验，添加User-Agent、Referer模拟浏览器请求
2. 增加错误捕获：先输出原始响应文本，确认返回内容是否为有效JSON
3. 优化日期格式生成：用Format函数替代拼接，避免格式错误

修改后的代码示例：

Option Explicit

Sub nseFixed()
    Dim req As New MSXML2.XMLHTTP60
    Dim url As String, defaultPayload As String, requestPayload As String, results() As String
    Dim payloadJSON As Object, responseJSON As Object, item As Object
    Dim startD As Date, endD As Date
    Dim key As Variant
    Dim i As Long, j As Long
    Dim rng As Range
    Dim rawResponse As String
    
    startD = DateSerial(2020, 2, 1) 'Start date
    endD = DateSerial(2020, 2, 29) 'end date
    url = "https://www.niftyindices.com/Backpage.aspx/getHistoricaldatatabletoString"
    defaultPayload = "{""name"":""NIFTY 50"",""startDate"":"""",""endDate"":""""}" '用双引号转义符合JSON规范
    Set rng = ThisWorkbook.Worksheets("NSE").Range("A2")

    '解析请求Payload
    Set payloadJSON = JsonConverter.ParseJson(defaultPayload)
    payloadJSON("startDate") = Format(startD, "DD-MMM-YYYY") '直接格式化更可靠
    payloadJSON("endDate") = Format(endD, "DD-MMM-YYYY")
    requestPayload = JsonConverter.ConvertToJson(payloadJSON)

    With req
        .Open "POST", url, False
        '补充请求头
        .setRequestHeader "Content-Type", "application/json; charset=UTF-8"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/120.0.0.0 Safari/537.36"
        .setRequestHeader "Referer", "https://www.niftyindices.com/historical-data"
        .send requestPayload
        
        '获取原始响应用于排查
        rawResponse = .responseText
        Debug.Print "原始响应：" & rawResponse
        
        '尝试解析响应并捕获错误
        On Error Resume Next
        Set responseJSON = JsonConverter.ParseJson(rawResponse)
        If Err.Number <> 0 Then
            MsgBox "响应解析失败，原始响应：" & rawResponse, vbCritical
            Exit Sub
        End If
        On Error GoTo 0
    End With

    '检查响应结构是否符合预期
    If Not responseJSON.Exists("d") Then
        MsgBox "响应结构不符合预期", vbExclamation
        Exit Sub
    End If

    Debug.Print "d字段内容：" & responseJSON("d")
    
    '解析d字段的JSON并捕获错误
    On Error Resume Next
    Set responseJSON = JsonConverter.ParseJson(responseJSON("d"))
    If Err.Number <> 0 Then
        MsgBox "d字段解析失败，内容：" & responseJSON("d"), vbCritical
        Exit Sub
    End If
    On Error GoTo 0

    '填充结果数组
    ReDim results(1 To responseJSON.Count, 1 To 7)
    i = 0
    For Each item In responseJSON
        i = i + 1
        j = 0
        For Each key In item
            j = j + 1
            results(i, j) = item(key)
        Next key
    Next item
    
    '写入工作表
    rng.Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

额外排查步骤 #

• 确认VBA-JSON库（JsonConverter）为最新版本，可从官方仓库更新
• 检查是否启用MSXML2.XMLHTTP60引用：VBA编辑器→工具→引用→勾选Microsoft XML, v6.0
• 手动访问网站历史数据页面，确认接口是否仍可正常访问或页面结构有无变化

内容的提问来源于stack exchange，提问作者Swat