使用Google API和JSON检索股票信息

Question

我正在制作一个dB来每天多次从Google财经中提取股票数据。起初我只是将数据拉出并保存为CSV文件，如下所示

Public Sub GrabQuotes()



Dim oXMLHTTP
Dim oStream


Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")


oXMLHTTP.Open "GET", "http://finance.google.com/finance/info?client=ig&q=CVX,XOM,HP,SLB,PBA,ATR,NVZMY,MON,MMM,CNI,EMR,UTX,ROK,XYL,IPGP,DE,JCI,TGT,HD,CVS,NSRGY,PG,PEP,STKL,UNFI,VZ,NGG,POR,ABT,JNJ,NVS,PRGO,RHHBY,ALNY,MDT,ILMN,ISIS,LH,NVO,AFL,CYN,AAPL,ADP,CSCO,EMC,FISV,GOOGL,MA,XLNX,QCOM,INTC,MSFT,NXPI,ORCL", False
oXMLHTTP.Send

If oXMLHTTP.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write oXMLHTTP.responseBody
    oStream.SaveToFile "\\HBFSBOS\APPS\TDID\StockQuotes\All.csv", 2
    oStream.Close
End If


End Sub

该脚本顺利运行。然后我发现检索的数据是JSON格式。我在https://json-csv.com/.

发现了一个很棒的JSON格式化工具

附加快捷方式并更新我的代码后，它看起来像这样：

Public Sub GrabQuotes()



Dim oXMLHTTP
Dim oStream


Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")

'Site address has to be encoded. Go to "http://meyerweb.com/eric/tools/dencoder/" to encode/decode


oXMLHTTP.Open "GET", "json-csv.com/?u=http%3A%2F%2Ffinance.google.com%2Ffinance%2Finfo%3Fclient%3Dig%26q%3DCVX%2CXOM%2CHP%2CSLB%2CPBA%2CATR%2CNVZMY%2CMON%2CMMM%2CCNI%2CEMR%2CUTX%2CROK%2CXYL%2CIPGP%2CDE%2CJCI%2CTGT%2CHD%2CCVS%2CNSRGY%2CPG%2CPEP%2CSTKL%2CUNFI%2CVZ%2CNGG%2CPOR%2CABT%2CJNJ%2CNVS%2CPRGO%2CRHHBY%2CALNY%2CMDT%2CILMN%2CISIS%2CLH%2CNVO%2CAFL%2CCYN%2CAAPL%2CADP%2CCSCO%2CEMC%2CFISV%2CGOOGL%2CMA%2CXLNX%2CQCOM%2CINTC%2CMSFT%2CNXPI%2CORCL", False
oXMLHTTP.Send

If oXMLHTTP.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write oXMLHTTP.responseBody
    oStream.SaveToFile "\\HBFSBOS\APPS\TDID\StockQuotes\All.csv", 2
    oStream.Close
End If


End Sub

我现在收到错误＆＃34;运行时错误＆＃39; -2147467259（80004005）＆＃39;：方法＆＃39;打开＆＃39;对象＆IXCEHTTPRequest＆＃39;失败＆＃34 ;.如果我将请求粘贴到Chrome中，也可以正常使用。我怎么改变它才能让它发挥作用？我是JSON和XMLHTTP的新手，所以任何帮助都会受到赞赏。

Answer 1

这是VBA。浏览器会自动添加https：//。我实际上决定尝试不同的角度，只关注获取数据。通过使用以下运作良好的方法。

Option Compare Database

Public Sub RunJSON()

Dim browser As Object 'defines browser as object


Set browser = CreateObject("InternetExplorer.Application") 'creates the object
browser.navigate "json-csv.com/?u=http%3A%2F%2Ffinance.google.com%2Ffinance%2Finfo%3Fclient%3Dig%26q%3DCVX%2CXOM%2CHP%2CSLB%2CPBA%2CATR%2CNVZMY%2CMON%2CMMM%2CCNI%2CEMR%2CUTX%2CROK%2CXYL%2CIPGP%2CDE%2CJCI%2CTGT%2CHD%2CCVS%2CNSRGY%2CPG%2CPEP%2CSTKL%2CUNFI%2CVZ%2CNGG%2CPOR%2CABT%2CJNJ%2CNVS%2CPRGO%2CRHHBY%2CALNY%2CMDT%2CILMN%2CISIS%2CLH%2CNVO%2CAFL%2CCYN%2CAAPL%2CADP%2CCSCO%2CEMC%2CFISV%2CGOOGL%2CMA%2CXLNX%2CQCOM%2CINTC%2CMSFT%2CNXPI%2CORCL"
Set browser = Nothing 'nullifies the object

End Sub

Answer 2

请考虑以下示例，它不需要https://json-csv.com或任何其他在线服务，也不需要InternetExplorer.Application，因此它更可靠：

Option Explicit

Sub GrabQuotesTest()

    Dim objXHR As Object
    Dim strCsv As String
    Dim i As Long
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim varItem As Variant
    Dim strDesktop As String

    ' grab google finance data
    Set objXHR = CreateObject("MSXML2.XMLHTTP.3.0")
    objXHR.Open "GET", "http://finance.google.com/finance/info?client=ig&q=CVX,XOM,HP,SLB,PBA,ATR,NVZMY,MON,MMM,CNI,EMR,UTX,ROK,XYL,IPGP,DE,JCI,TGT,HD,CVS,NSRGY,PG,PEP,STKL,UNFI,VZ,NGG,POR,ABT,JNJ,NVS,PRGO,RHHBY,ALNY,MDT,ILMN,ISIS,LH,NVO,AFL,CYN,AAPL,ADP,CSCO,EMC,FISV,GOOGL,MA,XLNX,QCOM,INTC,MSFT,NXPI,ORCL", False
    objXHR.Send
    Debug.Print objXHR.Status
    If objXHR.Status <> 200 Then Exit Sub
    strJsonString = objXHR.responseText

    ' trim extraneous chars
    For i = 1 To Len(strJsonString)
        Select Case Mid(strJsonString, i, 1)
            Case "[", "{": Exit For
        End Select
    Next
    strJsonString = Mid(strJsonString, i)

    ' parse json string
    ParseJson strJsonString, varJson, strState
    Debug.Print strState
    If strState = "Error" Then Exit Sub

    ' convert parsed json to csv
    strCsv = GetCsv(varJson)

    ' results output
    Debug.Print strCsv
    strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
    WriteTextFile strCsv, strDesktop & "\Quotes.csv", 0

End Sub

Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
    ' strContent - source JSON string
    ' varJson - created object or array to be returned as result
    ' strState - Object|Array|Error depending on processing to be returned as state
    Dim objTokens As Object
    Dim objRegEx As Object
    Dim bMatched As Boolean

    Set objTokens = CreateObject("Scripting.Dictionary")
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        ' specification http://www.json.org/
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "str"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
        .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
        Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
        If Not (.Test(strContent) And objTokens.Exists(strContent)) Then
            varJson = Null
            strState = "Error"
        Else
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    End With
End Sub

Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object

    strRes = ""
    lngCopyIndex = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & objTokens.Count & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object

    strType = Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                Next
                varTransfer = objArrayElts.Items
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) - 2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global = False
                .Pattern = "\\u[0-9a-fA-F]{4}"
                Do While .Test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
                Loop
            Case "num"
                varTransfer = Eval(strContent)
            Case "cst"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

Function GetCsv(arrItems)

    Dim strRowSep As String
    Dim strDecDelim As String
    Dim strColSep As String
    Dim strKey As Variant
    Dim lngPrevIdx As Long
    Dim lngFoundIdx As Long
    Dim arrHeader() As String
    Dim arrColumns() As String
    Dim arrRows() As String
    Dim i As Long
    Dim j As Long
    Dim objItem As Variant
    Dim varValue As Variant

    strRowSep = vbCrLf '
    strDecDelim = Mid(0.1, 2, 1)
    If strDecDelim = "." Then
        strColSep = ","
    Else
        strColSep = ";"
    End If
    If SafeUBound(arrItems) = -1 Then
        GetCsv = "No rows"
        Exit Function
    End If
    For Each objItem In arrItems
        lngPrevIdx = -1
        For Each strKey In objItem.Keys
            lngFoundIdx = GetArrayItemIndex(arrHeader, strKey)
            If lngFoundIdx = -1 Then
                If lngPrevIdx = -1 Then
                    ArrayAddItem arrHeader, strKey
                    lngPrevIdx = UBound(arrHeader)
                Else
                    ArrayInsertItem arrHeader, lngPrevIdx + 1, strKey
                    lngPrevIdx = lngPrevIdx + 1
                End If
            Else
                lngPrevIdx = lngFoundIdx
            End If
        Next
    Next
    If SafeUBound(arrHeader) = -1 Then
        GetCsv = "No columns"
        Exit Function
    End If
    GetCsv = Join(arrHeader, strColSep) & strRowSep
    ReDim arrColumns(UBound(arrHeader))
    ReDim arrRows(UBound(arrItems))
    For i = 0 To UBound(arrItems)
        Set objItem = arrItems(i)
        For j = 0 To UBound(arrHeader)
            strKey = arrHeader(j)
            varValue = objItem(strKey)
            Select Case VarType(varValue)
                Case vbInteger, vbLong, vbSingle, vbDouble
                    arrColumns(j) = varValue
                Case vbNull
                    arrColumns(j) = "Null"
                Case vbBoolean
                    arrColumns(j) = IIf(varValue, "True", "False")
                Case vbString
                    arrColumns(j) = """" & varValue & """"
                Case Else
                    arrColumns(j) = ""
            End Select
        Next
        arrRows(i) = Join(arrColumns, strColSep)
    Next
    GetCsv = GetCsv & Join(arrRows, strRowSep)
End Function

Function GetArrayItemIndex(arrElements, varTest)
    For GetArrayItemIndex = 0 To SafeUBound(arrElements)
        If arrElements(GetArrayItemIndex) = varTest Then Exit Function
    Next
    GetArrayItemIndex = -1
End Function

Sub ArrayAddItem(arrElements, varElement)
    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)
    arrElements(UBound(arrElements)) = varElement
End Sub

Sub ArrayInsertItem(arrElements, lngIndex, varElement)
    Dim i As Long
    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)
    For i = UBound(arrElements) To lngIndex + 1 Step -1
        arrElements(i) = arrElements(i - 1)
    Next
    arrElements(i) = varElement
End Sub

Function SafeUBound(arrTest)
    On Error Resume Next
    SafeUBound = -1
    SafeUBound = UBound(arrTest)
End Function

Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
    ' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
        .Write (strContent)
        .Close
    End With
End Sub

此示例适用于Access VBA，要在Excel上运行，必须将Eval函数替换为Evaluate。