Vba Json

蓝天630902 · 发表于 2013-4-6 20:37

创建一个“类模块”，命名为“VbaJson”
然后把下面的代码粘贴进去：

Private Whitespace, NumberRegex, StringChunk
Private b, f, r, n, t
Private Sub Class_Initialize()
Whitespace = " " & vbTab & vbCr & vbLf
b = ChrW(8)
f = vbFormFeed
r = vbCr
n = vbLf
t = vbTab
Set NumberRegex = New RegExp
NumberRegex.Pattern = "(-?(?:0|[1-9]\d*))(\.\d+)?([eE][-+]?\d+)?"
NumberRegex.Global = False
NumberRegex.MultiLine = True
NumberRegex.IgnoreCase = True
Set StringChunk = New RegExp
StringChunk.Pattern = "([\s\S]*?)([""\\\x00-\x1f])"
StringChunk.Global = False
StringChunk.MultiLine = True
StringChunk.IgnoreCase = True
End Sub
Public Function encode(ByRef obj)
Dim buf, i, c, g
Set buf = CreateObject("Scripting.Dictionary")
Select Case VarType(obj)
Case vbNull
buf.Add buf.Count, "null"
Case vbBoolean
If obj Then
buf.Add buf.Count, "true"
Else
buf.Add buf.Count, "false"
End If
Case vbInteger, vbLong, vbSingle, vbDouble
buf.Add buf.Count, obj
Case vbString
buf.Add buf.Count, """"
For i = 1 To Len(obj)
c = Mid(obj, i, 1)
Select Case c
Case """": buf.Add buf.Count, """"
Case "": buf.Add buf.Count, "\"
Case "/": buf.Add buf.Count, "/"
Case b: buf.Add buf.Count, "\b"
Case f: buf.Add buf.Count, "\f"
Case r: buf.Add buf.Count, "\r"
Case n: buf.Add buf.Count, "\n"
Case t: buf.Add buf.Count, "\t"
Case Else
If AscW(c) >= 0 And AscW(c) <= 31 Then
c = Right("0" & Hex(AscW(c)), 2)
buf.Add buf.Count, "\u00" & c
Else
buf.Add buf.Count, c
End If
End Select
Next
buf.Add buf.Count, """"
Case vbArray + vbVariant
g = True
buf.Add buf.Count, "["
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, encode(i)
Next
buf.Add buf.Count, "]"
Case vbObject
If TypeName(obj) = "Dictionary" Then
g = True
buf.Add buf.Count, "{"
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, """" & i & """" & ":" & encode(obj(i))
Next
buf.Add buf.Count, "}"
Else
Err.Raise 8732, , "None dictionary object"
End If
Case Else
buf.Add buf.Count, """" & CStr(obj) & """"
End Select
encode = Join(buf.Items, "")
End Function
Public Function Decode(ByRef str)
Dim idx
idx = SkipWhitespace(str, 1)
If Mid(str, idx, 1) = "{" Then
Set Decode = ScanOnce(str, 1)
Else
Decode = ScanOnce(str, 1)
End If
End Function
Private Function ScanOnce(ByRef str, ByRef idx)
Dim c, ms
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "{" Then
idx = idx + 1
Set ScanOnce = parseObject(str, idx)
Exit Function
ElseIf c = "[" Then
idx = idx + 1
ScanOnce = parseArray(str, idx)
Exit Function
ElseIf c = """" Then
idx = idx + 1
ScanOnce = parseString(str, idx)
Exit Function
ElseIf c = "n" And StrComp("null", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = Null
Exit Function
ElseIf c = "t" And StrComp("true", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = True
Exit Function
ElseIf c = "f" And StrComp("false", Mid(str, idx, 5)) = 0 Then
idx = idx + 5
ScanOnce = False
Exit Function
End If
Set ms = NumberRegex.Execute(Mid(str, idx))
If ms.Count = 1 Then
idx = idx + ms(0).Length
ScanOnce = CDbl(ms(0))
Exit Function
End If
Err.Raise 8732, , "No JSON object could be ScanOnced"
End Function
Private Function parseObject(ByRef str, ByRef idx)
Dim c, key, value
Set parseObject = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "}" Then
Exit Function
ElseIf c <> """" Then
Err.Raise 8732, , "Expecting property name"
End If
idx = idx + 1
Do
key = parseString(str, idx)
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) <> ":" Then
Err.Raise 8732, , "Expecting : delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
If Mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
parseObject.Add key, value
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "}" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732, , "Expecting , delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
c = Mid(str, idx, 1)
If c <> """" Then
Err.Raise 8732, , "Expecting property name"
End If
idx = idx + 1
Loop
idx = idx + 1
End Function
Private Function parseArray(ByRef str, ByRef idx)
Dim c, values, value
Set values = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "]" Then
parseArray = values.Items
Exit Function
End If
Do
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
values.Add values.Count, value
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "]" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732, , "Expecting , delimiter"
End If
idx = idx + 1
Loop
idx = idx + 1
parseArray = values.Items
End Function
Private Function parseString(ByRef str, ByRef idx)
Dim chunks, content, terminator, ms, esc, char
Set chunks = CreateObject("Scripting.Dictionary")
Do
Set ms = StringChunk.Execute(Mid(str, idx))
If ms.Count = 0 Then
Err.Raise 8732, , "Unterminated string starting"
End If
content = ms(0).Submatches(0)
terminator = ms(0).Submatches(1)
If Len(content) > 0 Then
chunks.Add chunks.Count, content
End If
idx = idx + ms(0).Length
If terminator = """" Then
Exit Do
ElseIf terminator <> "" Then
Err.Raise 8732, , "Invalid control character"
End If
esc = Mid(str, idx, 1)
If esc <> "u" Then
Select Case esc
Case """": char = """"
Case "": char = ""
Case "/": char = "/"
Case "b": char = b
Case "f": char = f
Case "n": char = n
Case "r": char = r
Case "t": char = t
Case Else: Err.Raise 8732, , "Invalid escape"
End Select
idx = idx + 1
Else
: char = ChrW("&H" & Mid(str, idx + 1, 4))
idx = idx + 5
End If
chunks.Add chunks.Count, char
Loop
parseString = Join(chunks.Items, "")
End Function
Private Function SkipWhitespace(ByRef str, ByVal idx)
Do While idx <= Len(str) And _
InStr(Whitespace, Mid(str, idx, 1)) > 0
idx = idx + 1
Loop
SkipWhitespace = idx
End Function
Function ParseJson(strJson)
Set HTML = CreateObject("htmlfile")
Set Window = HTML.parentWindow
Window.execScript "var json = " & strJson, "JScript"
Set ParseJson = Window.json
End Function

复制代码

然后，用下面的代码测试：

Private Sub CommandButton1_Click() '时时彩
Dim tt As String
Columns("B:B").NumberFormatLocal = "@"
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "http://baidu.lecai.com/lottery/draw/view/200", False
.send
tt = Split(Split(Replace(.responseText, "[]", """"""), "var phaseData = ")(1), ";")(0)
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText tt
.PutInClipboard
End With
'读取json开始
Dim json
Set json = New VbaJson
Set r = json.Decode(tt)
i = 0
For Each v In r
For Each s In r(v)
t = ""
For Each u In r(v)(s)("result")("red")
t = t & u
Next
i = i + 1
Cells(i, 1) = s
Cells(i, 2) = t
Cells(i, 3) = r(v)(s)("open_time")
Next
Next
Set json = Nothing
'读取json结束
End With
End Sub

复制代码

蓝天630902 · 发表于 2013-4-6 20:40

这个是上面的附件：

liucqa · 发表于 2013-4-6 21:07

http://demon.tw/my-work/vbs-json.html

蓝天630902 · 发表于 2013-4-7 07:21

本帖最后由蓝天630902 于 2013-4-7 16:19 编辑

这个是
game88city
不过呢，最好是不要赌，赌必输。

ccwan · 发表于 2013-4-7 08:35

感谢分享，这样就方便很多了

yangxhhb · 发表于 2013-4-7 11:24

偶是新手，水平还没到建立类的程度，但相信总有一天会看懂的。谢谢分享！

liucqa · 发表于 2013-4-7 14:38

蓝天630902 发表于 2013-4-7 07:21
这个是
game88city
不过呢，最好是不要赌，赌必输。

不能运行，你的代码没处理防盗链吧。

另外，是不是给人做义工去了？{:soso_e112:}

cumulonimbus · 发表于 2013-4-14 19:46

哇，这么厉害，只能仰望之。

cumulonimbus · 发表于 2013-4-15 00:02

本帖最后由 cumulonimbus 于 2013-4-15 14:05 编辑

百度词典下载{:soso_e113:}已解决。

jackeyin2009 · 发表于 2013-4-15 12:22

学习中，不知道那天能够达到如此水平

		自动登录	找回密码
密码			免费注册

[分享] Vba Json

评分

点评

请问要如何下载百度词典里的数据？想了一个晚上还想不出来。(附件已上传)谢谢