Question

我已经开发了一个代码来从网站上抓取数据，但是由于我对JSON知之甚少，因此我可以按照下面的快照所示获取所需的输出：

但是，我正在立即窗口中从Web上获取所有数据，但想要像上面的快照一样组织这些字段。这是我的代码：

_db.Movies.Add(newMovie)

立即窗口中的输出为：

Answer 1

以下显示了如何使用json解析器。我使用jsonconverter.bas。将代码从那里复制到称为JsonConverter的标准模块后，您需要转到VBE>工具>参考>添加对Microsoft脚本运行时的引用。

在json响应中，{}是由key访问的字典； []是按索引（或For Each以上）访问的集合

Option Explicit

Public Sub FetchTabularInfo()
    Dim Http As New XMLHTTP60, Html As New HTMLDocument
    Dim col As Variant, icol As New Collection
    Dim csrf As Variant, i&

    With Http
        .Open "GET", "https://ngodarpan.gov.in/index.php/home/statewise_ngo/76/35/1", False
        .send
        Html.body.innerHTML = .responseText
    End With

    With Html.querySelectorAll(".table tr a[onclick^='show_ngo_info']")
        For i = 0 To .Length - 1
            icol.Add Split(Split(.item(i).getAttribute("onclick"), "(""")(1), """)")(0)
        Next i
    End With

    Dim r As Long, headers(), results(), ws As Worksheet

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    headers = Array("SrNo", "Name of VGO/NGO", "Address", "City", "State", "Tel", "Mobile", "Web", "Email")
    ReDim results(1 To icol.Count, 1 To UBound(headers) + 1)

    For Each col In icol
        r = r + 1
        With Http
            .Open "GET", "https://ngodarpan.gov.in/index.php/ajaxcontroller/get_csrf", False
            .send
            csrf = .responseText
        End With

        csrf = Split(Replace(Split(csrf, ":")(1), """", ""), "}")(0)

        Dim json As Object
        With Http
            .Open "POST", "https://ngodarpan.gov.in/index.php/ajaxcontroller/show_ngo_info", False
            .setRequestHeader "X-Requested-With", "XMLHttpRequest"
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
            .send "id=" & col & "&csrf_test_name=" & csrf
            Set json = JsonConverter.ParseJson(.responseText)

            Dim orgName As String, address As String, srNo As Long, city As String
            Dim state As String, tel As String, mobile As String, website As String, email As String

            On Error Resume Next
            orgName = json("registeration_info")(1)("nr_orgName")
            address = json("registeration_info")(1)("nr_add")
            city = json("registeration_info")(1)("nr_city")
            srNo = r '<unsure where this is coming from.
            state = Replace$(json("registeration_info")(1)("StateName"), "amp;", vbNullString)
            tel = IIf(IsNull(json("infor")("0")("Off_phone1")), vbNullString, json("infor")("0")("Off_phone1")) '<unsure where this is coming from. Need a csrf to test with
            mobile = json("infor")("0")("Mobile")
            website = json("infor")("0")("ngo_url")
            email = json("infor")("0")("Email")
            On Error GoTo 0

            Dim arr()
            arr = Array(srNo, orgName, address, city, state, tel, mobile, website, email)
            For i = LBound(headers) To UBound(headers)
               results(r, i + 1) = arr(i)
            Next
        End With
    Next col
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

使用JSON在Excel中导入数据

1 个答案: