'Please read disclaimer before using this code.
Option Explicit
Dim que As String
Public Sub Add(s As String)
que = que & s
End Sub
Public Function Remove() As String
Remove = que
que = ""
End Function
Public Function parseJSONArray(json As String) As Collection
Dim col As New Collection
Dim i As Long
Dim start As Boolean
Dim start1 As Integer
Dim start2 As Boolean
Dim start3 As Boolean
Dim c As String * 1
i = 1
Do While i <= Len(json)
c = Mid(json, i, 1)
If start = False Then
If c = " " Then
'Ignore
ElseIf c = "[" Then
start = True
Else
Set parseJSONArray = Nothing
End If
Else
If ((start1 = 0 And start2 = False) Or start3 = True) And (c = "," Or c = "]") Then
col.Add Remove
ElseIf start1 = 0 And start2 = False And start3 = False Then
If c = "{" Then
start1 = start1 + 1
Add c
ElseIf c = """" Then
start2 = True
ElseIf start2 = True And c = "\" Then 'Convert \" to "
c = Mid(json, i + 1, 1)
If c = """" Then
Add c: i = i + 1
Else
Add "\"
End If
ElseIf c = " " Then
'Skip
Else
start3 = True
Add c
End If
ElseIf start1 > 0 Then
If c = "{" Then start1 = start1 + 1
If c = "}" Then start1 = start1 - 1
Add c
ElseIf start2 = True And c = """" Then
start2 = False
Else
Add c
End If
End If
i = i + 1
Loop
Set parseJSONArray = col
End Function
Public Function parseJSONObject(ByVal json As String) As Collection
Dim start As Boolean
Dim start1 As Boolean
Dim start2 As Boolean
Dim start22 As Boolean
Dim col As New Collection
Dim code As String
Dim arStart As Integer
Dim obStart As Integer
Dim loc As Integer
Dim i As Long
loc = 2
arStart = 0: obStart = 0
Dim s As String
Dim c As String
s = json
i = 1
Do While i <= Len(s)
c = Mid(s, i, 1)
If start = False Then
If c = " " Then
'Ignore
ElseIf c = "{" Then
start = True
Else
Set parseJSONObject = Nothing
End If
Else
If start2 = True And arStart > 0 Then
If c = "[" Then arStart = arStart + 1
If c = "]" Then arStart = arStart - 1
Add c
ElseIf start2 = True And obStart > 0 Then
If c = "{" Then obStart = obStart + 1
If c = "}" Then obStart = obStart - 1
Add c
ElseIf start2 = True And c = "[" Then
arStart = arStart + 1 'Value part is an Array
Add c
ElseIf start2 = True And c = "{" Then
obStart = obStart + 1 'Value part is an Object
Add c
ElseIf start2 = True And c = "\" Then 'Convert \" to "
c = Mid(s, i + 1, 1)
If c = """" Then
Add c: i = i + 1
Else
Add "\"
End If
ElseIf start1 = False And start2 = False And c = """" Then
start1 = True 'Name part start
ElseIf start1 = True And c = """" Then
code = Remove 'Name part end
start1 = False
ElseIf start1 = False And start2 = False And c = ":" Then
start2 = True 'Value part start
ElseIf start2 = True And start22 = False And arStart = 0 And obStart = 0 And (c = "," Or c = "}") Then
col.Add Remove, code 'Value part end
start2 = False
ElseIf start2 = True And c = """" Then
If start22 = True Then
start22 = False
Else
start22 = True
End If
Else
Add c
End If
If start2 = False Then start22 = False
End If
i = i + 1
Loop
Set parseJSONObject = col
End Function
Public Function stringToDate(dt As String, Optional splitSymbl As String = "-") As Date
Dim a() As String
a = Strings.Split(dt, splitSymbl)
If UBound(a) = 2 Then
stringToDate = DateSerial(a(2), a(1), a(0))
Else
Err.Raise 9999, "StringToDate Function", "Invalid Date!"
End If
End Function
Option Explicit
Dim que As String
Public Sub Add(s As String)
que = que & s
End Sub
Public Function Remove() As String
Remove = que
que = ""
End Function
Public Function parseJSONArray(json As String) As Collection
Dim col As New Collection
Dim i As Long
Dim start As Boolean
Dim start1 As Integer
Dim start2 As Boolean
Dim start3 As Boolean
Dim c As String * 1
i = 1
Do While i <= Len(json)
c = Mid(json, i, 1)
If start = False Then
If c = " " Then
'Ignore
ElseIf c = "[" Then
start = True
Else
Set parseJSONArray = Nothing
End If
Else
If ((start1 = 0 And start2 = False) Or start3 = True) And (c = "," Or c = "]") Then
col.Add Remove
ElseIf start1 = 0 And start2 = False And start3 = False Then
If c = "{" Then
start1 = start1 + 1
Add c
ElseIf c = """" Then
start2 = True
ElseIf start2 = True And c = "\" Then 'Convert \" to "
c = Mid(json, i + 1, 1)
If c = """" Then
Add c: i = i + 1
Else
Add "\"
End If
ElseIf c = " " Then
'Skip
Else
start3 = True
Add c
End If
ElseIf start1 > 0 Then
If c = "{" Then start1 = start1 + 1
If c = "}" Then start1 = start1 - 1
Add c
ElseIf start2 = True And c = """" Then
start2 = False
Else
Add c
End If
End If
i = i + 1
Loop
Set parseJSONArray = col
End Function
Public Function parseJSONObject(ByVal json As String) As Collection
Dim start As Boolean
Dim start1 As Boolean
Dim start2 As Boolean
Dim start22 As Boolean
Dim col As New Collection
Dim code As String
Dim arStart As Integer
Dim obStart As Integer
Dim loc As Integer
Dim i As Long
loc = 2
arStart = 0: obStart = 0
Dim s As String
Dim c As String
s = json
i = 1
Do While i <= Len(s)
c = Mid(s, i, 1)
If start = False Then
If c = " " Then
'Ignore
ElseIf c = "{" Then
start = True
Else
Set parseJSONObject = Nothing
End If
Else
If start2 = True And arStart > 0 Then
If c = "[" Then arStart = arStart + 1
If c = "]" Then arStart = arStart - 1
Add c
ElseIf start2 = True And obStart > 0 Then
If c = "{" Then obStart = obStart + 1
If c = "}" Then obStart = obStart - 1
Add c
ElseIf start2 = True And c = "[" Then
arStart = arStart + 1 'Value part is an Array
Add c
ElseIf start2 = True And c = "{" Then
obStart = obStart + 1 'Value part is an Object
Add c
ElseIf start2 = True And c = "\" Then 'Convert \" to "
c = Mid(s, i + 1, 1)
If c = """" Then
Add c: i = i + 1
Else
Add "\"
End If
ElseIf start1 = False And start2 = False And c = """" Then
start1 = True 'Name part start
ElseIf start1 = True And c = """" Then
code = Remove 'Name part end
start1 = False
ElseIf start1 = False And start2 = False And c = ":" Then
start2 = True 'Value part start
ElseIf start2 = True And start22 = False And arStart = 0 And obStart = 0 And (c = "," Or c = "}") Then
col.Add Remove, code 'Value part end
start2 = False
ElseIf start2 = True And c = """" Then
If start22 = True Then
start22 = False
Else
start22 = True
End If
Else
Add c
End If
If start2 = False Then start22 = False
End If
i = i + 1
Loop
Set parseJSONObject = col
End Function
Public Function stringToDate(dt As String, Optional splitSymbl As String = "-") As Date
Dim a() As String
a = Strings.Split(dt, splitSymbl)
If UBound(a) = 2 Then
stringToDate = DateSerial(a(2), a(1), a(0))
Else
Err.Raise 9999, "StringToDate Function", "Invalid Date!"
End If
End Function
No comments:
Post a Comment