考虑下面的例子，它不需要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。