VBA处理JSON文件的类模块

JSON格式目前越来越流行，具体JSON格式的描述可以在JSON网站[www.json.org]了解，这里水文工具集给出一个VBA处理JSON文件的类模块，以方便调用。JSON格式目前越来越流行，具体JSON格式的描述可以在JSON网站[www.json.org]了解，这里水文工具集给出一个VBA处理JSON文件的类模块，以方便调用。



Option Explicit

002.'================================

003.' VBA处理JSON文件的类模块

004.'

005.' http://www.cnhup.com

006.'================================

007.Const INVALID_JSON      As Long = 1

008.Const INVALID_OBJECT    As Long = 2

009.Const INVALID_ARRAY     As Long = 3

010.Const INVALID_BOOLEAN   As Long = 4

011.Const INVALID_NULL      As Long = 5

012.Const INVALID_KEY       As Long = 6

013. 

014.Private Sub Class_Initialize()

015. 

016.End Sub

017. 

018.Private Sub Class_Terminate()

019. 

020.End Sub

021. 

022.Public Function parse(ByRef str As String) AsObject

023. 

024.Dim index As Long

025.index = 1

026. 

027.On Error Resume Next

028. 

029.Call skipChar(str, index)

030.Select Case Mid(str, index, 1)

031.Case "{"

032.Set parse = parseObject(str, index)

033.Case "["

034.Set parse = parseArray(str, index)

035.End Select

036. 

037.End Function

038. 

039.Private Function parseObject(ByRef str AsString, ByRef index As Long) As Object

040. 

041.Set parseObject = CreateObject("Scripting.Dictionary")

042. 

043.' "{"

044.Call skipChar(str, index)

045.If Mid(str, index, 1) <> "{" Then Err.Raise vbObjectError + INVALID_OBJECT, Description:="char " & index & " : " & Mid(str, index)

046.index = index + 1

047. 

048.Do

049. 

050.Call skipChar(str, index)

051.If "}" = Mid(str, index, 1) Then

052.index = index + 1

053.Exit Do

054.ElseIf "," = Mid(str, index, 1) Then

055.index = index + 1

056.Call skipChar(str, index)

057.End If

058. 

059.Dim key As String

060. 

061.' add key/value pair

062.parseObject.Add key:=parseKey(str, index), Item:=parseValue(str, index)

063. 

064.Loop

065. 

066.End Function

067. 

068.Private Function parseArray(ByRef str AsString, ByRef index As Long) As Collection

069. 

070.Set parseArray = New Collection

071. 

072.' "["

073.Call skipChar(str, index)

074.If Mid(str, index, 1) <> "[" Then Err.Raise vbObjectError + INVALID_ARRAY, Description:="char " & index & " : " + Mid(str, index)

075.index = index + 1

076. 

077.Do

078. 

079.Call skipChar(str, index)

080.If "]" = Mid(str, index, 1) Then

081.index = index + 1

082.Exit Do

083.ElseIf "," = Mid(str, index, 1) Then

084.index = index + 1

085.Call skipChar(str, index)

086.End If

087. 

088.' add value

089.parseArray.Add parseValue(str, index)

090. 

091.Loop

092. 

093.End Function

094. 

095.Private Function parseValue(ByRef str AsString, ByRef index As Long)

096. 

097.Call skipChar(str, index)

098. 

099.Select Case Mid(str, index, 1)

100.Case "{"

101.Set parseValue = parseObject(str, index)

102.Case "["

103.Set parseValue = parseArray(str, index)

104.Case """", "'"

105.parseValue = parseString(str, index)

106.Case "t", "f"

107.parseValue = parseBoolean(str, index)

108.Case "n"

109.parseValue = parseNull(str, index)

110.Case Else

111.parseValue = parseNumber(str, index)

112.End Select

113. 

114.End Function

115. 

116.Private Function parseString(ByRef str AsString, ByRef index As Long) As String

117. 

118.Dim quote   As String

119.Dim char    As String

120.Dim code    As String

121. 

122.Call skipChar(str, index)

123.quote = Mid(str, index, 1)

124.index = index + 1

125.Do While index > 0 And index <= Len(str)

126.char = Mid(str, index, 1)

127.Select Case (char)

128.Case "\"

129.index = index + 1

130.char = Mid(str, index, 1)

131.Select Case (char)

132.Case """", "\\", "/"

133.parseString = parseString & char

134.index = index + 1

135.Case "b"

136.parseString = parseString & vbBack

137.index = index + 1

138.Case "f"

139.parseString = parseString & vbFormFeed

140.index = index + 1

141.Case "n"

142.parseString = parseString & vbNewLine

143.index = index + 1

144.Case "r"

145.parseString = parseString & vbCr

146.index = index + 1

147.Case "t"

148.parseString = parseString & vbTab

149.index = index + 1

150.Case "u"

151.index = index + 1

152.code = Mid(str, index, 4)

153.parseString = parseString & ChrW(val("&h" + code))

154.index = index + 4

155.End Select

156.Case quote

157.index = index + 1

158.Exit Function

159.Case Else

160.parseString = parseString & char

161.index = index + 1

162.End Select

163.Loop

164. 

165.End Function

166. 

167.Private Function parseNumber(ByRef str AsString, ByRef index As Long)

168. 

169.Dim value   As String

170.Dim char    As String

171. 

172.Call skipChar(str, index)

173.Do While index > 0 And index <= Len(str)

174.char = Mid(str, index, 1)

175.If InStr("+-0123456789.eE", char) Then

176.value = value & char

177.index = index + 1

178.Else

179.If InStr(value, ".") OrInStr(value, "e") Or InStr(value,"E") Then

180.parseNumber = CDbl(value)

181.Else

182.parseNumber = CInt(value)

183.End If

184.Exit Function

185.End If

186.Loop

187. 

188. 

189.End Function

190. 

191.Private Function parseBoolean(ByRef str AsString, ByRef index As Long) As Boolean

192. 

193.Call skipChar(str, index)

194.If Mid(str, index, 4) = "true" Then

195.parseBoolean = True

196.index = index + 4

197.ElseIf Mid(str, index, 5) = "false" Then

198.parseBoolean = False

199.index = index + 5

200.Else

201.Err.Raise vbObjectError + INVALID_BOOLEAN, Description:="char "& index & " : " & Mid(str, index)

202.End If

203. 

204.End Function

205. 

206.Private Function parseNull(ByRef str As String,ByRef index As Long)

207. 

208.Call skipChar(str, index)

209.If Mid(str, index, 4) = "null" Then

210.parseNull = Null

211.index = index + 4

212.Else

213.Err.Raise vbObjectError + INVALID_NULL, Description:="char " & index & " : "& Mid(str, index)

214.End If

215. 

216.End Function

217. 

218.Private Function parseKey(ByRef str As String,ByRef index As Long) As String

219. 

220.Dim dquote  As Boolean

221.Dim squote  As Boolean

222.Dim char    As String

223. 

224.Call skipChar(str, index)

225.Do While index > 0 And index <= Len(str)

226.char = Mid(str, index, 1)

227.Select Case (char)

228.Case """"

229.dquote = Not dquote

230.index = index + 1

231.If Not dquote Then

232.Call skipChar(str, index)

233.If Mid(str, index, 1) <> ":"Then

234.Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey

235.End If

236.End If

237.Case "'"

238.squote = Not squote

239.index = index + 1

240.If Not squote Then

241.Call skipChar(str, index)

242.If Mid(str, index, 1) <> ":"Then

243.Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey

244.End If

245.End If

246.Case ":"

247.If Not dquote And Not squote Then

248.index = index + 1

249.Exit Do

250.End If

251.Case Else

252.If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", char) Then

253.Else

254.parseKey = parseKey & char

255.End If

256.index = index + 1

257.End Select

258.Loop

259. 

260.End Function

261. 

262.Public Sub skipChar(ByRef str As String, ByRefindex As Long)

263. 

264.While index > 0 And index <= Len(str) AndInStr(vbCrLf & vbCr & vbLf & vbTab & " ", Mid(str, index, 1))

265.index = index + 1

266.Wend

267. 

268.End Sub

269. 

270.Public Function toString(ByRef obj As Variant)As String

271. 

272.Select Case VarType(obj)

273.Case vbNull

274.toString = "null"

275.Case vbDate

276.toString = """" & CStr(obj) & """"

277.Case vbString

278.toString = """" & encode(obj) &""""

279.Case vbObject

280.Dim bFI, i

281.bFI = True

282.If TypeName(obj) = "Dictionary"Then

283.toString = toString & "{"

284.Dim keys

285.keys = obj.keys

286.For i = 0 To obj.Count - 1

287.If bFI Then bFI = FalseElse toString = toString & ","

288.Dim key

289.key = keys(i)

290.toString = toString & """"& key & """:" & toString(obj(key))

291.Next i

292.toString = toString & "}"

293.ElseIf TypeName(obj) = "Collection"Then

294.toString = toString & "["

295.Dim value

296.For Each value In obj

297.If bFI Then bFI = FalseElse toString = toString & ","

298.toString = toString & toString(value)

299.Next value

300.toString = toString & "]"

301.End If

302.Case vbBoolean

303.If obj Then toString = "true" ElsetoString = "false"

304.Case vbVariant, vbArray, vbArray + vbVariant

305.Dim sEB

306.toString = multiArray(obj, 1, "", sEB)

307.Case Else

308.toString = Replace(obj, ",", ".")

309.End Select

310. 

311.End Function

312. 

313.Private Function encode(str) As String

314. 

315.Dim i, j, aL1, aL2, c, p

316. 

317.aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)

318.aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)

319.For i = 1 To Len(str)

320.p = True

321.c = Mid(str, i, 1)

322.For j = 0 To 7

323.If c = Chr(aL1(j)) Then

324.encode = encode & "\" & Chr(aL2(j))

325.p = False

326.Exit For

327.End If

328.Next

329. 

330.If p Then

331.Dim a

332.a = AscW(c)

333.If a > 31 And a < 127 Then

334.encode = encode & c

335.ElseIf a > -1 Or a < 65535 Then

336.encode = encode & "\u" &String(4 - Len(Hex(a)), "0") & Hex(a)

337.End If

338.End If

339.Next

340.End Function

341. 

342.Private Function multiArray(aBD, iBC, sPS,ByRef sPT)   ' Array BoDy, Integer BaseCount, String PoSition

343.Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound

344.On Error Resume Next

345.iDL = LBound(aBD, iBC)

346.iDU = UBound(aBD, iBC)

347. 

348.Dim sPB1, sPB2  ' String PointBuffer1, String PointBuffer2

349.If Err.Number = 9 Then

350.sPB1 = sPT & sPS

351.For i = 1 To Len(sPB1)

352.If i <> 1 Then sPB2 = sPB2 & ","

353.sPB2 = sPB2 & Mid(sPB1, i, 1)

354.Next

355.'        multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))

356.multiArray = multiArray & toString(aBD(sPB2))

357.Else

358.sPT = sPT & sPS

359.multiArray = multiArray & "["

360.For i = iDL To iDU

361.multiArray = multiArray & multiArray(aBD, iBC + 1, i, sPT)

362.If i < iDU Then multiArray = multiArray & ","

363.Next

364.multiArray = multiArray & "]"

365.sPT = Left(sPT, iBC - 2)

366.End If

367.Err.Clear

368.End Function