‘（1）把json数据放到excel中

Sub GetJSONDemo()

    'url = "http://191.168.0.158:9092/api/index/quotaIntfs/getQuotaIntfGorupTreeWithDetailTable?pageNum=1&pageSize=10&pageSizes=10&pageSizes=20&pageSizes=50&pageSizes=100&t=1619769732746"

    url = "http://191.168.0.158:7081/module/router?begDate=2014-04-01&endDate=2014-04-30&moduleNo=JXYL_REPORT02&freqType=N&otherParam=GT_201208174713&appKey=xquant.xpacs&portCode=PT_C_795&nodeList=1,2&landMid=false"

    Dim json$, arr()

    json = GetJsonByUrl(url)

    Debug.Print json

   

    arr = ParseJSON(json)

   

   ' Dim sht As Worksheet

   ' Set sht = Worksheets("Sheet5")

    'With sht

       ' .Range(Cells(1, 1), Cells(3, 1)).Value2 = WorksheetFunction.Transpose(arr) '填入列

        '.Range(Cells(1, 2), Cells(1, 4)).Value2 = arr '填入行

    'End With

End Sub

 

Function GetJsonByUrl(ByVal url As String)

    Application.DefaultWebOptions.Encoding = msoEncodingUTF8

 

    Dim http

    Set http = CreateObject("Msxml2.ServerXMLHTTP")

    http.Open "GET", url, False

    'http.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"

    'http.setRequestHeader "Cookie", "SESSION=YjlkNTA5OGMtNGM5MC00ZTJlLTg5ODktOTk0ZWUzYzExMjFi"

    http.send

    If http.Status = 200 Then

        Dim json$

        json = http.responseText

        GetJsonByUrl = json

    End If

End Function

'json = {"a":["a1","a2","a3"], "count":3}

Function ParseJSON(ByVal json As String)

    'Set objSC = CreateObject("ScriptControl")  '用于32位Excel

    Set objSC = CreateObjectx86("MSScriptControl.ScriptControl")  '用于64位Excel, 不过需要引入另一个模块

    objSC.Language = "JScript"

    strjson = "var json=" & json & ";"

    objSC.AddCode (strjson)

   

    Dim count As Integer

    count = objSC.eval("json.resultList.length")

    Dim arr()

    Cells(1, 1) = "id"

    Cells(1, 2) = "nodeName"

    Cells(1, 3) = "gbHldNetMtm"

    Cells(1, 4) = "endDate"

    Cells(1, 5) = "aType"

    Cells(1, 6) = "nickName"

    Cells(1, 7) = "parentNodeId"

    Cells(1, 8) = "portCode"

    Cells(1, 9) = "leaf"

    Cells(1, 10) = "mType"

    Cells(1, 11) = "iCode"

    Cells(1, 12) = "nodeLevel"

    Cells(1, 13) = "pName"

    Cells(1, 14) = "begDate"

    Cells(1, 15) = "gbHldCountPre"

    Cells(1, 16) = "aName"

    Cells(1, 17) = "gbHldCount"

    Cells(1, 18) = "iName"

    Cells(1, 19) = "nodeIndex"

    Cells(1, 20) = "mName"

    Cells(1, 21) = "nodeId"

   

    ReDim arr(1 To count)

    For i = 1 To count

        'arr(i) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]")

        Cells(i + 1, 1) = i

        Cells(i + 1, 2) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".nodeName")

        Cells(i + 1, 3) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".gbHldNetMtm")

        Cells(i + 1, 4) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".endDate")

        Cells(i + 1, 5) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".aType")

        Cells(i + 1, 6) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".nickName")

        Cells(i + 1, 7) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".parentNodeId")

        Cells(i + 1, 8) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".portCode")

        Cells(i + 1, 9) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".leaf")

        Cells(i + 1, 10) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".mType")

        Cells(i + 1, 11) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".iCode")

        Cells(i + 1, 12) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".nodeLevel")

        Cells(i + 1, 13) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".pName")

        Cells(i + 1, 14) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".begDate")

        Cells(i + 1, 15) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".gbHldCountPre")

        Cells(i + 1, 16) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".aName")

        Cells(i + 1, 17) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".gbHldCount")

        Cells(i + 1, 18) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".iName")

        Cells(i + 1, 19) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".nodeIndex")

        Cells(i + 1, 20) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".mName")

        Cells(i + 1, 21) = objSC.eval("json.resultList" + "[" + CStr(i - 1) + "]" + ".nodeId")

    Next

  

    'Dim cnt As Integer

    'cnt = objSC.eval("json.count")

   

    'Dim arr()

    'ReDim arr(1 To cnt)

   

    'For i = 1 To cnt

        'arr(i) = objSC.eval("json.index" + ".index" + CStr(i - 1))

        'arr(i) = objSC.eval("json.result" + ".result" + CStr(i - 1))

    

    'Next

 

    ParseJSON = arr

End Function

 

Function CreateObjectx86(Optional sProgID, Optional bClose = False)

    Static oWnd As Object

    Dim bRunning As Boolean

    #If Win64 Then

        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0

        If bClose Then

            If bRunning Then oWnd.Close

            Exit Function

        End If

        If Not bRunning Then

            Set oWnd = CreateWindow()

            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"

        End If

        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)

    #Else

        Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")

    #End If

End Function

 

 

Function CreateWindow()

    Dim sSignature, oShellWnd, oProc

    On Error Resume Next

    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)

    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False

    Do

        For Each oShellWnd In CreateObject("Shell.Application").Windows

            Set CreateWindow = oShellWnd.GetProperty(sSignature)

            If Err.Number = 0 Then Exit Function

            Err.Clear

        Next

    Loop

End Function

 

‘把表中的数据插入数据库中

 

Sub linkOracle10()

 

    Dim strConn As String  '连接字符串

   

    Dim dbConn As Object  '连接对象

    Dim resSet As Object  '查询结果集

   

    Dim db_sid, db_user, db_pass As String 'sid,用户名,密码

   

    '设置自己的链接数据

    db_sid = "ORCL_158"

    db_user = "xqa"

    db_pass = "xrisk"

   

    '创建对象

    Set dbConn = CreateObject("ADODB.Connection")

    Set resSet = CreateObject("ADODB.Recordset")

    '拼接链接字符串 下面两个选一个

    strConn = "Provider=OraOLEDB.Oracle.1; user id=" & db_user & "; password=" & db_pass & "; data source = " & db_sid & "; Persist Security Info=True"

    'strConn = "Provider=MSDAORA.1; user id=" & db_user & "; password=" & db_pass & "; data source = " & db_sid & "; Persist Security Info=True"

      

 

    '-----打开数据库----

    dbConn.Open strConn

   

 'dbConn.Execute ("delete DEMO1")

'计算该表有多少行

RowCount = Worksheets("Sheet1").UsedRange.Rows.count

'行循环

For irow = 2 To RowCount

 strRecord = ""

'列循环,假设有五列,从第一列开始

For icol = 1 To 21

If icol <> 21 Then

strRecord = strRecord & "'" & Worksheets("Sheet1").Cells(irow, icol).Value & "'" & ","

Else

strRecord = strRecord & "'" & Worksheets("Sheet1").Cells(irow, icol).Value & "'"

End If

Next

'MsgBox strRecord

Sql = dbConn.Execute("insert into DEMO2 values(" & strRecord & ")")

Next

MsgBox "插入完成"

 

   

    '-----关闭连接----

    dbConn.Close '关闭数据库

   

End Sub