Skip to content

Instantly share code, notes, and snippets.

@brucemcpherson

brucemcpherson/cJobject.cls

Last active September 21, 2024 05:41
Show Gist options
  • Save brucemcpherson/3414365 to your computer and use it in GitHub Desktop.
Save brucemcpherson/3414365 to your computer and use it in GitHub Desktop.
Download ZIP
cJobject class for VBA - converts jSon/excel
Raw
cJobject.cls
'[email protected] :do not modify this line - see ramblings.mcpher.com for details: updated on 8/9/2014 3:09:42 PM : from manifest:3414394 gist https://gist.github.com/brucemcpherson/3414365/raw
' this is used for object serliazation. Its just basic JSON with only string data types catered for
Option Explicit
' v2.19 3414365
'for more about this
' http://ramblings.mcpher.com/Home/excelquirks/classeslink/data-manipulation-classes
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' http://ramblings.mcpher.com/Home/excelquirks/codeuse
Private pParent As cJobject
Private pValue As Variant
Private pKey As String
Private pChildren As Collection
Private pValid As Boolean
Private pIndex As Long
Const cNull = "_null"
Const croot = "_deserialization"
Private pFake As Boolean ' not a real key
Private pisArrayRoot ' this is the root of an array
Private pPointer As Long ' this one is used for deserializing string
Private pJstring As String ' so is this
Private pWhatNext As String
Private pActive As Boolean
Private pJtype As eDeserializeType
Private pBacktrack As cJobject ' used in parsing
Public Enum eDeserializeType
eDeserializeNormal
eDeserializeGoogleWire
End Enum
' this is for treeview - i couldnt find it anywhere
Public Enum tvw
tvwFirst = 0
tvwLast = 1
tvwNext = 2
tvwPrevious = 3
tvwChild = 4
End Enum
Public Property Get backtrack() As cJobject
Set backtrack = pBacktrack
End Property
Public Property Set backtrack(back As cJobject)
Set pBacktrack = back
End Property
Public Property Get self() As cJobject
Set self = Me
End Property
Public Property Get isValid() As Boolean
isValid = pValid
End Property
Public Property Let setValid(good As Boolean)
pValid = good
End Property
Public Property Get jString() As String
jString = pJstring
End Property
Public Property Get fake() As Boolean
fake = pFake
If Not pParent Is Nothing Then
fake = fake And pParent.isArrayRoot
End If
End Property
Public Property Get childIndex() As Long
childIndex = pIndex
End Property
Public Property Let childIndex(p As Long)
pIndex = p
End Property
Public Property Get isArrayRoot() As Boolean
isArrayRoot = pisArrayRoot
End Property
Public Property Get isArrayMember() As Boolean
If Not pParent Is Nothing Then
isArrayMember = pParent.isArrayRoot
Else
isArrayMember = False
End If
End Property
Public Property Let isArrayRoot(p As Boolean)
pisArrayRoot = p
End Property
Public Property Get parent() As cJobject
Set parent = pParent
End Property
Public Property Set parent(p As cJobject)
Set pParent = p
End Property
Public Property Get isRoot() As Boolean
isRoot = (root Is Me)
End Property
Public Sub clearParent()
Set pParent = Nothing
End Sub
Public Property Get root() As cJobject
Dim jo As cJobject
' the root is the object with no parent
Set jo = Me
While Not jo.parent Is Nothing
Set jo = jo.parent
Wend
Set root = jo
End Property
Public Property Get key() As String
key = pKey
End Property
Public Property Get value() As Variant
value = pValue
End Property
Public Function cValue(Optional childName As String = vbNullString) As Variant
If childName = vbNullString Then
cValue = value
Else
cValue = child(childName).value
End If
End Function
Public Function toString(Optional childName As String = vbNullString) As String
toString = CStr(cValue(childName))
End Function
Public Property Let value(p As Variant)
pValue = p
End Property
Public Property Get children() As Collection
Set children = pChildren
End Property
Public Property Set children(p As Collection)
Set pChildren = p
End Property
Public Property Get hasChildren() As Boolean
hasChildren = False
If Not pChildren Is Nothing Then
hasChildren = (pChildren.count > 0)
End If
End Property
Public Function deleteChild(childName As String) As cJobject
' this deletes a child from the children collection
Dim job As cJobject, target As cJobject
Set target = childExists(childName)
If (Not target Is Nothing) Then
children.remove target.childIndex
For Each job In children
If job.childIndex > target.childIndex Then
job.childIndex = job.childIndex - 1
End If
Next job
target.teardown
End If
Set deleteChild = Me
End Function
Public Function valueIndex(v As Variant) As Long
' check to see if h is in the cj array
Dim cj As cJobject
valueIndex = 0
For Each cj In children
If cj.value = v Then
valueIndex = cj.childIndex
Exit Function
End If
Next cj
End Function
Public Function toTreeView(tr As Object, Optional bEnableCheckBoxes As Boolean = False) As Object
' this populates a treeview with a cJobject
tr.CheckBoxes = bEnableCheckBoxes
Set toTreeView = treeViewPopulate(tr, Me)
End Function
Private Function treeViewPopulate(tr As Object, cj As cJobject, Optional parent As cJobject = Nothing)
Dim c As cJobject, s As String
s = vbNullString
If cj.hasChildren Then
s = cj.key
Else
s = cj.key + " : " & cj.toString
End If
If (Not parent Is Nothing) Then
tr.nodes.add parent.fullKey, tvwChild, cj.fullKey, s
Else
tr.nodes.add(, , cj.fullKey, cj.key).Expanded = True
End If
For Each c In cj.children
treeViewPopulate tr, c, cj
Next c
Set treeViewPopulate = tr
End Function
Public Function init(p As cJobject, Optional k As String = cNull, Optional v As Variant = Empty) As cJobject
Set pParent = p
Set pBacktrack = p
pFake = (k = cNull)
If pFake Then
pKey = CStr(pIndex)
Else
pKey = k
End If
If Not pParent Is Nothing Then
If Not child(pKey) Is Nothing Then
MsgBox ("Programming error " & pKey & " is a duplicate object")
pValid = False
Else
pIndex = pParent.children.count + 1
If pFake Then
pKey = CStr(pIndex)
End If
pParent.children.add Me, pKey
End If
End If
pValue = v
Set init = Me
End Function
Public Function child(s As String) As cJobject
Dim aString As Variant, n As Long, jo As cJobject, jc As cJobject
If Len(s) > 0 Then
aString = Split(s, ".")
Set jo = Me
' we take something x.y.z and find the child
For n = LBound(aString) To UBound(aString)
Set jc = jo.childExists(CStr(aString(n)))
Set jo = jc
If jo Is Nothing Then Exit For
Next n
End If
Set child = jo
End Function
Public Function insert(Optional s As String = cNull, Optional v As Variant = Empty) As cJobject
Dim joNew As cJobject, sk As String
Set joNew = childExists(s)
If joNew Is Nothing Then
' if its an array, use the child index as the name if there is no name given
If pisArrayRoot And s = cNull Then
sk = cNull
Else
sk = s
End If
Set joNew = New cJobject
joNew.init Me, sk, v
Else
If Not IsEmpty(v) Then joNew.value = v
End If
Set insert = joNew
End Function
Public Function add(Optional k As String = cNull, Optional v As Variant = Empty) As cJobject
Dim aString As Variant, n As Long, jo As cJobject, jc As cJobject
aString = Split(k, ".")
Set jo = Me
' we take something x.y.z and add z with parent of y
For n = LBound(aString) To UBound(aString)
Set jc = jo.insert(CStr(aString(n)), v)
Set jo = jc
Next n
Set add = jo
End Function
Public Function addArray() As cJobject
pisArrayRoot = True
Set addArray = Me
End Function
' check if this childExists in current children
Public Function childExists(s As String) As cJobject
On Error GoTo handle
Set childExists = pChildren(s)
Exit Function
handle:
Set childExists = Nothing
End Function
Private Function unSplitToString(a As Variant, delim As String, _
Optional startAt As Long = -999, Optional howMany As Long = -999, _
Optional startAtEnd As Boolean = False) As String
Dim s As String, c As cStringChunker, i As Long
' sort out possible boundaries
If startAt = -999 Then startAt = LBound(a)
If howMany = -999 Then howMany = UBound(a) - startAt + 1
If startAtEnd Then startAt = UBound(a) - howMany + 1
' will return nullstring on outside bounds
If startAt < LBound(a) Or howMany + startAt - 1 > UBound(a) Then
unSplitToString = vbNullString
Else
Set c = New cStringChunker
' combine and convert to string
For i = startAt To startAt + howMany - 1
c.add(CStr(a(i))).add delim
Next i
unSplitToString = c.chopIf(delim).content
Set c = Nothing
End If
End Function
Public Function find(s As String) As cJobject
Dim jo As cJobject, f As cJobject, k As String, fk As String, possible As Boolean
k = makeKey(s)
fk = makeKey(fullKey(False))
' need to deal with find("x.y.z") as well as simple find("x")
Dim kk As String, a As Variant, b As Variant
b = Split(fk, ".")
a = Split(k, ".")
kk = unSplitToString(b, ".", , arrayLength(a), True)
'now the fullkey is the same number of items as the key to compare it against
If kk = k Then
Set f = Me
ElseIf hasChildren Then
For Each jo In pChildren
Set f = jo.find(s)
If Not f Is Nothing Then Exit For
Next jo
End If
Set find = f
End Function
Public Function convertToArray() As cJobject
' here's where have something like {x:{a:'x',b:'y'}} and we need to make {x:[{a:'x',b:'y'}]}
Dim kids As Collection, newParent As cJobject, job As cJobject, newRoot As cJobject, i As Long
' if its got no kids but has a value then we need to assign that value
If Not hasChildren Then
addArray
If Not IsEmpty(value) Then
' make a space for the value
add , value
Else
' do nothing
End If
Set convertToArray = Me
Else
' we need to make a space for the object and for each child
Set kids = children
' remove current item
parent.children.remove (key)
' reset child indices
i = 0
For Each job In parent.children
i = i + 1
job.childIndex = i
Next job
' add a new version of me
Set newRoot = parent.add(key).addArray
' move over contents
With newRoot.add
For Each job In kids
.add job.key, job.value
Next job
End With
Set convertToArray = newRoot
End If
End Function
Public Function fullKey(Optional includeRoot As Boolean = True) As String
' reconstruct full key to parent
Dim s As String, jo As cJobject
Set jo = Me
While Not jo Is Nothing
If (Not jo.isRoot) Or includeRoot Then s = jo.key & "." & s
Set jo = jo.parent
Wend
If Len(s) > 0 Then s = left(s, Len(s) - 1)
fullKey = s
End Function
Public Function findByValue(x As Variant) As cJobject
Dim job As cJobject, result As cJobject
If value = x Then
Set findByValue = Me
Exit Function
Else
For Each job In children
Set result = job.findByValue(x)
If Not result Is Nothing Then
Set findByValue = result
Exit Function
End If
Next job
End If
End Function
Public Function hasKey() As Boolean
hasKey = pKey <> vbNullString And _
pKey <> cNull And _
(hasChildren Or Not isArrayMember) And Not pFake
End Function
Public Function needsCurly() As Boolean
needsCurly = hasKey
If hasChildren Then
needsCurly = pChildren(1).hasKey
End If
End Function
Public Function needsSquare() As Boolean
needsSquare = isArrayRoot
End Function
Public Function stringify(Optional blf As Boolean) As String
stringify = serialize(blf)
End Function
Public Function serialize(Optional blf As Boolean = False) As String
' make a JSON string of this structure
Dim t As cStringChunker
Set t = New cStringChunker
If Not fake Then t.add "{"
recurseSerialize Me, t, blf
If Not fake Then t.add "}"
serialize = t.content
End Function
Public Property Get needsIndent() As Boolean
needsIndent = needsCurly Or needsSquare
End Property
Public Function recurseSerialize(job As cJobject, Optional soFar As cStringChunker = Nothing, _
Optional blf As Boolean = False) As cStringChunker
Dim s As String, jo As cJobject, t As cStringChunker
Static indent As Long
If indent = 0 Then indent = 3
If soFar Is Nothing Then
Set t = New cStringChunker
Else
Set t = soFar
End If
If blf And (job.hasKey Or job.needsCurly) Then t.add Space(indent)
If job.hasKey Then
t.add(quote(job.key)).add (":")
End If
If Not (job.hasChildren Or job.isArrayRoot) Then
If blf And Not job.hasKey Then s = s & Space(indent)
If (VarType(job.value) <> vbLong And _
VarType(job.value) <> vbBoolean And _
VarType(job.value) <> vbInteger And _
VarType(job.value) <> vbDouble And Not IsEmpty(job.value)) _
Then
t.add quote(CStr(escapeify(job.value)))
Else
If Not IsEmpty(job.value) Then
t.add LCase(job.toString)
Else
t.add "null"
End If
End If
Else
' arrays need squares
If job.needsSquare Then t.add "["
If job.needsCurly Then t.add "{"
If blf And Not job.isArrayRoot Then t.add vbLf
If job.needsIndent Then
indent = indent + 3
End If
For Each jo In job.children
recurseSerialize(jo, t, blf).add (",")
If blf Then t.add (vbLf)
Next jo
' get rid of trailing comma
t.chopWhile(" ").chopIf(vbLf).chopIf (",")
If job.needsIndent Then
indent = indent - 3
If blf Then t.add vbLf
End If
If blf Then t.add Space(indent)
If job.needsCurly Then t.add "}"
If job.needsSquare Then t.add " ]"
End If
Set recurseSerialize = t
End Function
Public Property Get longestFullKey() As Long
longestFullKey = clongestFullKey(root)
End Property
Public Function clone() As cJobject
Dim cj As cJobject
Set cj = New cJobject
Set cj = cj.init(Nothing).append(Me).children(1)
cj.clearParent
Set clone = cj
End Function
Public Function merge(mergeThisIntoMe As cJobject) As cJobject
' merge this cjobject with another
' items in merged with are replaced with items in Me
Dim cj As cJobject, p As cJobject
Set p = Me.find(mergeThisIntoMe.fullKey(False))
If p Is Nothing Then
' i dont have it yet
Set p = Me.append(mergeThisIntoMe)
Else
' actually i do have it already
If p.isArrayRoot Then
' but its an array - i need to get rid of it
Set p = p.remove
Set p = p.append(mergeThisIntoMe)
Else
p.value = mergeThisIntoMe.value
End If
End If
' now the other childreb tio merge in
For Each cj In mergeThisIntoMe.children
p.merge cj
Next cj
Set merge = Me
End Function
Public Function remove() As cJobject
' removes a branch
Dim cj As cJobject, p As cJobject, i As Long
Debug.Assert Not parent Is Nothing
Debug.Assert parent.hasChildren
parent.children.remove childIndex
' fix the childindices
i = 0
For Each cj In parent.children
i = i + 1
cj.childIndex = i
Next cj
Set remove = parent
End Function
Public Function append(appendThisToMe As cJobject) As cJobject
' append another object to me
Dim cj As cJobject, p As cJobject
If appendThisToMe.parent Is Nothing Then
Set p = Me.add(appendThisToMe.key, appendThisToMe.value)
ElseIf Not appendThisToMe.fake Then
Set p = Me.add(appendThisToMe.key, appendThisToMe.value)
Else
Set p = Me.add(, appendThisToMe.value)
End If
If appendThisToMe.isArrayRoot Then p.addArray
For Each cj In appendThisToMe.children
p.append cj
Next cj
Set append = Me
End Function
Public Property Get depth(Optional l As Long = 0) As Long
Dim jo As cJobject
l = l + 1
For Each jo In pChildren
l = jo.depth(l)
Next jo
depth = l
End Property
Private Function clongestFullKey(job As cJobject, Optional soFar As Long = 0) As Long
Dim jo As cJobject
Dim l As Long
l = Len(job.fullKey)
If l < soFar Then l = soFar
If Not job.children Is Nothing Then
For Each jo In job.children
l = clongestFullKey(jo, l)
Next jo
End If
clongestFullKey = l
End Function
Public Property Get formatData(Optional bDebug As Boolean = False) As String
formatData = cformatdata(root, , bDebug)
End Property
Private Function cformatdata(job As cJobject, Optional soFar As String = "", Optional bDebug As Boolean = False) As String
Dim jo As cJobject, ji As cJobject
Dim s As String
s = soFar
s = s & itemFormat(job, bDebug)
If job.hasChildren Then
For Each ji In job.children
s = cformatdata(ji, s, bDebug)
Next ji
End If
cformatdata = s
End Function
Private Function itemFormat(jo As cJobject, Optional bDebug As Boolean = False) As String
Dim s As String
s = jo.fullKey & Space(longestFullKey + 4 - Len(jo.fullKey)) _
& CStr(jo.value)
If bDebug Then
s = s + "("
s = s & "debug: Haskey :" & jo.hasKey & " NeedsCurly :" & jo.needsCurly & " NeedsSquare:" & jo.needsSquare
s = s + " isArrayMember:" & jo.isArrayMember & " isArrayRoot:" & jo.isArrayRoot & " Fake:" & jo.fake
s = s & ")"
End If
itemFormat = s + vbCrLf
End Function
Public Sub jdebug()
Debug.Print formatData(True)
End Sub
Private Function quote(s As String) As String
quote = q & s & q
End Function
Public Function parse(s As String, Optional jtype As eDeserializeType, Optional complain As Boolean = True) As cJobject
Dim j As cJobject
Set j = deSerialize(s, jtype, complain)
If j.key = croot Then
' drop fake header
j.sever
End If
Set parse = j
End Function
Public Function deSerialize(s As String, Optional jtype As eDeserializeType = eDeserializeNormal, Optional complain As Boolean = True) As cJobject
' this will take a simple JSON string and deserialize into a cJobject branch starting at ME
' prepare string for processing
Dim jo As cJobject
pPointer = 1
pJstring = noisyTrim(s)
Set jo = New cJobject
jo.init Nothing, croot
pJtype = jtype
Set jo = dsLoop(jo, complain)
' already has its own root
If jtype = eDeserializeGoogleWire Then
Set jo = jo.children(1)
jo.clearParent
End If
jo.setValid = pValid
Set deSerialize = jo
End Function
Public Function sever() As cJobject
pKey = cNull
Set pParent = Nothing
Set sever = Me
pFake = True
End Function
Private Function noisyTrim(s As String) As String
Dim ns As String
ns = Trim(s)
If Len(ns) > 0 Then
While (isNoisy(Right(ns, 1)))
ns = left(ns, Len(ns) - 1)
Wend
End If
noisyTrim = ns
End Function
Private Function nullItem(job As cJobject) As cJobject
Set nullItem = Nothing
If peek() = "," Then
' need an array element
' simulate a { 'x':'x}
If pJtype = eDeserializeGoogleWire Then
Set nullItem = job.add.add("v")
Else
Set nullItem = job.add
End If
End If
End Function
Private Function dsLoop(job As cJobject, Optional complain As Boolean = True) As cJobject
Dim cj As cJobject, jo As cJobject, ws As String
Set jo = job
pActive = True
pWhatNext = "{["
While pPointer <= Len(pJstring) And pActive
Set jo = dsProcess(jo, complain)
Wend
Set dsLoop = job
End Function
Private Function okWhat(what As String) As Boolean
okWhat = (InStr(pWhatNext, nOk) <> 0 And _
(what = "." Or what = "-" Or IsNumeric(what))) Or _
(InStr(pWhatNext, what) <> 0)
End Function
Private Function peekNextToken() As String
' this is in case the next token is a special
Dim k As Long
peekNextToken = vbNullString
ignoreNoise
k = pPointer
While Not (isQuote(pointedAt(k)) Or isNoisy(pointedAt(k)) Or _
IsNumeric(pointedAt(k)) Or 0 <> InStr("[]{},.:", pointedAt(k)))
k = k + 1
Wend
If (k > pPointer) Then peekNextToken = LCase(pointedAt(, k - pPointer))
End Function
Private Function doNextToken() As String
Dim nextToken As String
' poke around to fix exceptions like null, false, true
nextToken = peekNextToken
If nextToken = "null" Then
pPointer = pPointer + Len(nextToken)
ignoreNoise
doNextToken = pointedAt
ElseIf nextToken = "false" Then
doNextToken = "0"
pPointer = pPointer + Len(nextToken)
ElseIf nextToken = "true" Then
doNextToken = "1"
pPointer = pPointer + Len(nextToken)
End If
End Function
Private Function dsProcess(job As cJobject, Optional complain As Boolean = True) As cJobject
Dim k As Long, jo As cJobject, s As String, what As String, jd As cJobject, v As Variant
Dim nextToken As String, nt As String, a As Variant, av As String, jt As cJobject
'are we done?
Set dsProcess = job
If pPointer > Len(pJstring) Then Exit Function
Set jo = job
ignoreNoise
nextToken = doNextToken
If nextToken <> vbNullString Then
what = nextToken
Else
what = pointedAt
End If
' is it what was expected
If Not okWhat(what) Then
badJSON pWhatNext, , complain
Exit Function
End If
' process next token
Select Case what
' start of key:value pair- do nothing except set up to get the key name
Case "{"
pPointer = pPointer + 1
If jo.isArrayRoot Then Set jo = jo.add
Set dsProcess = jo
pWhatNext = anyQ & ",}"
' its the beginning of an array - need to kick off a new array
Case "["
pPointer = pPointer + 1
If jo.isArrayRoot Then
' this is a double [[
Set jo = jo.add
End If
If nullItem(jo.addArray) Is Nothing Then
pWhatNext = nOk & anyQ & "{],["
Else
pWhatNext = ","
End If
Set dsProcess = jo
' could be a key or an array value
Case q, qs, "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "-", "."
v = getvItem(, nextToken)
If IsEmpty(v) Then
badJSON pWhatNext, , complain
Else
' start of key/value pair
If peek() = ":" Then
' add as a new key, and set up for getting the value
Set jt = jo
Set jo = jo.add(CStr(v))
Set jo.backtrack = jt
pWhatNext = ":"
ElseIf jo.isArrayRoot Then
' an array value is allowed without a key
jo.add , v
pWhatNext = ",]"
Else
badJSON pWhatNext, , complain
End If
Set dsProcess = jo
End If
' its the value of a pair
Case ":"
pPointer = pPointer + 1
nt = peekNextToken
v = getvItem(, doNextToken)
If IsEmpty(v) And nt <> "null" Then
' about to start an array rather than get a value
pWhatNext = "{["
Else
' store the value, come back for the next
' boolean hack
If (v = 1 And nt = "true") Then
v = True
ElseIf (v = 0 And nt = "false") Then
v = False
End If
jo.value = v
Set jo = jo.backtrack
pWhatNext = ",}"
End If
Set dsProcess = jo
Case ","
' another value - same set
pPointer = pPointer + 1
If nullItem(jo) Is Nothing Then
pWhatNext = nOk & anyQ & "{}],["
Else
pWhatNext = ","
End If
Set dsProcess = jo
Case "}"
' backup a level
pPointer = pPointer + 1
pWhatNext = ",]}"
Set dsProcess = jo.backtrack
Case "]"
' backup a level
pPointer = pPointer + 1
pWhatNext = ",}]"
Set dsProcess = jo.backtrack
Case Else
' unexpected thing happened
badJSON pWhatNext, , complain
End Select
End Function
Private Function nOk() As String
' some character to say that a numeric is ok
nOk = Chr(254)
End Function
Private Function getvItem(Optional whichQ As String = "", Optional nextToken = vbNullString) As Variant
Dim s As String
' is it a string?
getvItem = Empty
ignoreNoise
Select Case nextToken
Case "1"
getvItem = 1
Case "0"
getvItem = 0
Case Else
If isQuote(pointedAt) Then
getvItem = getQuotedItem(whichQ)
Else
' maybe its a number
s = getNumericItem
If Len(s) > 0 Then getvItem = toNumber(s)
End If
End Select
End Function
Private Function peek() As String
Dim k As Long
' peek ahead to next non noisy character
k = pPointer
ignoreNoise
peek = pointedAt
pPointer = k
End Function
Private Function peekBehind() As String
Dim k As Long
k = pPointer - 1
While k > 0 And isNoisy(pointedAt(k))
k = k - 1
Wend
If k > 0 Then
peekBehind = pointedAt(k)
End If
End Function
Private Function toNumber(sIn As String) As Variant
' convert string to numeric , either double or long
Dim ts As String, s As String, x As Date
' find out the '.' separator for this locale
ts = Mid(CStr(1.1), 2, 1)
' and use it so that cdbl works properly
s = Replace(sIn, ".", ts)
On Error GoTo overflow
If InStr(1, s, ts) Then
toNumber = CDbl(s)
Else
toNumber = CLng(s)
End If
Exit Function
overflow:
'perhaps this is a javascript date
On Error GoTo overflowAgain
If (Len(s) = 13) Then
x = DateAdd("s", CDbl(left(s, 10)), DateSerial(1970, 1, 1))
End If
toNumber = x
Resume Next
Exit Function
overflowAgain:
'this wasnt a javascript date
toNumber = 0
Resume Next
Exit Function
End Function
Private Function pointedAt(Optional pos As Long = 0, Optional sLen As Long = 1) As String
' return what ever the currently quoted character is
Dim k As Long
If pos = 0 Then
k = pPointer
Else
k = pos
End If
pointedAt = Mid(pJstring, k, sLen)
End Function
Private Function getQuotedItem(Optional whichQ As String = "") As String
Dim s As String, k As Long, wq As String
ignoreNoise
s = ""
If isQuote(pointedAt, whichQ) Then
wq = pointedAt
' extract until the next matching quote
k = pPointer + 1
While Not isQuote(pointedAt(k), wq)
If isUnicode(pointedAt(k, 2)) Then
s = s & ChrW(CLng("&H" & pointedAt(k + 2, 4)))
'S = S & StrConv(Hex2Dec(pointedAt(k + 2, 4)), vbFromUnicode)
k = k + 6
ElseIf isEscape(pointedAt(k)) Then
Select Case LCase(pointedAt(k + 1))
Case "t"
s = s & vbTab
Case "n"
s = s & vbLf
Case "r"
s = s & vbCr
Case Else
s = s & pointedAt(k + 1)
End Select
k = k + 2
Else
s = s & pointedAt(k)
k = k + 1
End If
Wend
pPointer = k + 1
End If
getQuotedItem = s
End Function
Private Function getNumericItem() As String
Dim s As String, k As Long, eAllowed As Boolean
ignoreNoise
s = vbNullString
eAllowed = False
k = pPointer
While IsNumeric(pointedAt(k)) Or pointedAt(k) = "." Or pointedAt(k) = "-" Or (eAllowed And pointedAt(k) = "E")
s = s & pointedAt(k)
eAllowed = InStr(1, s, "E") < 1
k = k + 1
Wend
pPointer = pPointer + Len(s)
getNumericItem = s
End Function
Private Function isQuote(s As String, Optional whichQ As String = "") As Boolean
If Len(whichQ) = 0 Then
' any quote
isQuote = (s = q Or s = qs)
Else
isQuote = (s = whichQ)
End If
End Function
Private Sub badJSON(pWhatNext As String, Optional add As String = "", Optional complain As Boolean = True)
If (complain) Then
MsgBox add & "got " & pointedAt & " expected --(" & pWhatNext & _
")-- Bad JSON at character " & CStr(pPointer) & " starting at " & _
Mid(pJstring, pPointer)
End If
pValid = False
pActive = False
End Sub
Private Sub ignoreNoise(Optional pos As Long = 0, Optional extraNoise As String = "")
Dim k As Long, t As Long
If pos = 0 Then
t = pPointer
Else
t = pos
End If
For k = t To Len(pJstring)
If Not isNoisy(Mid(pJstring, k, 1), extraNoise) Then Exit For
Next k
pPointer = k
End Sub
Private Function isNoisy(s As String, Optional extraNoise As String = "") As Boolean
isNoisy = InStr(vbTab & " " & vbCrLf & vbCr & vbLf & extraNoise, s)
End Function
Private Function isEscape(s As String) As Boolean
isEscape = (s = "\")
End Function
Private Function isUnicode(s As String) As Boolean
isUnicode = LCase(s) = "\u"
End Function
Private Function q() As String
q = Chr(34)
End Function
Private Function qs() As String
qs = Chr(39)
End Function
Private Function anyQ() As String
anyQ = q & qs
End Function
Public Function addD3TreeItem(ds As cDataSet, label As String, key As String, parentkey As String, _
Optional drd As cDataRow = Nothing) As cJobject
Dim cj As cJobject, dr As cDataRow, Cc As cCell
' does parent key exist?
Set cj = find(parentkey)
If (cj Is Nothing) Then
Set dr = findD3Parent(ds, parentkey)
If Not dr Is Nothing Then
Set cj = addD3TreeItem(ds, label, parentkey, cleanDot(dr.cell("Parent key").toString), dr)
End If
End If
If cj Is Nothing Then
MsgBox ("could not find " & key & " " & parentkey)
Else
With cj.add(key)
.add "label", label
' anything else on this row?
If Not drd Is Nothing Then
For Each Cc In drd.columns
If (Cc.myKey <> "key" And Cc.myKey <> "label" And _
Cc.myKey <> "parent key" And Not IsEmpty(Cc.value)) Then
.add Cc.myKey, Cc.value
End If
Next Cc
End If
End With
End If
Set addD3TreeItem = cj
End Function
Private Function findD3Parent(ds As cDataSet, parentkey) As cDataRow
Dim dr As cDataRow
For Each dr In ds.rows
If cleanDot(dr.cell("key").toString) = parentkey Then
Set findD3Parent = dr
Exit Function
End If
Next dr
End Function
Private Function cleanDot(s As String) As String
'. has special meaning for cJobject so if present in key, then remove
cleanDot = makeKey(Replace(s, ".", "_ _"))
End Function
Public Function makeD3Tree(ds As cDataSet, dsOptions As cDataSet, Optional options As String = "options") As cJobject
' this one will take a list of Name/Parents and make a structured cJobject out of it
Dim dr As cDataRow, cj As cJobject, parent As String, name As String, c3 As cJobject, ct As cJobject
Const container = "contents"
If Not ds.headingRow.validate(True, "Label", "Parent Key", "Key") Then Exit Function
Set cj = add("D3Root")
For Each dr In ds.rows
Set ct = cj.addD3TreeItem(ds, _
dr.cell("label").toString, _
cleanDot(dr.cell("key").toString), _
cleanDot(dr.cell("Parent key").toString), dr)
Next dr
' now lets tweak that to a d3 format
Set c3 = New cJobject
With c3.init(Nothing)
' add an options branch
With .add("options")
For Each dr In dsOptions.rows
If dr.cell("value").toString <> vbNullString Then
.add dr.cell(options).toString, _
dr.cell("value").toString
End If
Next dr
End With
' add a branch for data
With .add("data")
.add "label", dsOptions.cell("root", "value").toString
.makeD3 cj.children(1)
End With
End With
Set makeD3Tree = c3
End Function
Public Function makeD3(cj As cJobject) As cJobject
Dim cjc As cJobject
If cj.hasChildren Then
With add("children").addArray.add
For Each cjc In cj.children
.makeD3 cjc
Next cjc
End With
Else
add cj.key, cj.value
End If
Set makeD3 = Me
End Function
Public Sub teardown()
Dim cj As cJobject
If Not pChildren Is Nothing Then
For Each cj In pChildren
cj.teardown
Next cj
End If
Set pParent = Nothing
Set pBacktrack = Nothing
Set pChildren = Nothing
End Sub
Private Sub Class_Initialize()
pisArrayRoot = False
pValid = True
pIndex = 1
Set pChildren = New Collection
End Sub
Raw
usefulcJobject.vba
'[email protected] :do not modify this line - see ramblings.mcpher.com for details: updated on 8/9/2014 3:09:43 PM : from manifest:3414394 gist https://gist.github.com/brucemcpherson/3414365/raw/usefulcJobject.vba
'v2.13
Option Explicit
Public Function fromISODateTime(iso As String) As Date
Dim rx As RegExp, matches As MatchCollection, d As Date, ms As Double, sec As Double
Set rx = New RegExp
With rx
.ignorecase = True
.Global = True
.Pattern = "(\d{4})-([01]\d)-([0-3]\d)T([0-2]\d):([0-5]\d):(\d*\.?\d*)Z"
End With
Set matches = rx.execute(iso)
' TODO -- timeszone
If matches.count = 1 And matches.item(0).SubMatches.count = 6 Then
With matches.item(0)
sec = CDbl(.SubMatches(5))
ms = sec - Int(sec)
d = DateSerial(.SubMatches(0), .SubMatches(1), .SubMatches(2)) + _
TimeSerial(.SubMatches(3), .SubMatches(4), Int(sec)) + ms / 86400
End With
Else
d = 0
End If
fromISODateTime = d
End Function
Public Function toISODateTime(d As Date) As String
Dim s As String, ms As Double, adjustSecond As Long
' need to adjust if seconds are going to be rounded up
ms = milliseconds(d)
adjustSecond = 0
If (ms >= 0.5) Then adjustSecond = -1
' TODO - timezone
toISODateTime = Format(year(d), "0000") & "-" & Format(month(d), "00") & "-" & Format(day(d), "00T") & _
Format(d, "hh:mm:") & Format(DateAdd("s", adjustSecond, d), "ss") & Format(ms, ".000Z")
End Function
Public Function milliseconds(d As Date) As Double
' extract the milliseconds from the time
Dim t As Date
t = (d - DateSerial(year(d), month(d), day(d)) - TimeSerial(hour(d), Minute(d), Second(d)))
If t < 0 Then
' the millsecond rounded it up
t = (d - DateSerial(year(d), month(d), day(d)) - TimeSerial(hour(d), Minute(d), Second(d) - 1))
End If
milliseconds = t * 86400
End Function
Public Function JSONParse(s As String, Optional jtype As eDeserializeType, Optional complain As Boolean = True) As cJobject
Dim j As New cJobject
Set JSONParse = j.init(Nothing).parse(s, jtype, complain)
j.teardown
End Function
Public Function JSONStringify(j As cJobject, Optional blf As Boolean) As String
JSONStringify = j.stringify(blf)
End Function
Public Function jSonArgs(options As String) As cJobject
' takes a javaScript like options paramte and converts it to cJobject
' it can be accessed as job.child('argName').value or job.find('argName') etc.
Dim job As New cJobject
If options <> vbNullString Then
Set jSonArgs = job.init(Nothing, "jSonArgs").deSerialize(options)
End If
End Function
Public Function optionsExtend(givenOptions As String, _
Optional defaultOptions As String = vbNullString) As cJobject
Dim jGiven As cJobject, jDefault As cJobject, _
jExtended As cJobject, cj As cJobject
' this works like $.extend in jQuery.
' given and default options arrive as a json string
' example -
' optionsExtend ("{'width':90,'color':'blue'}", "{'width':20,'height':30,'color':'red'}")
' would return a cJobject which serializes to
' "{width:90,height:30,color:blue}"
Set jGiven = jSonArgs(givenOptions)
Set jDefault = jSonArgs(defaultOptions)
' now we combine them
If Not jDefault Is Nothing Then
Set jExtended = jDefault
Else
Set jExtended = New cJobject
jExtended.init Nothing
End If
' now we merge that with whatever was given
If Not jGiven Is Nothing Then
jExtended.merge jGiven
End If
' and its over
Set optionsExtend = jExtended
End Function
'udfs to expose classes
Public Function ucJobjectMake(r As Variant) As cJobject
Dim cj As New cJobject
Set ucJobjectMake = cj.deSerialize(CStr(r))
End Function
Public Function ucJobjectChildValue(json As Variant, child As Variant) As String
ucJobjectChildValue = ucJobjectMake(CStr(json)).child(CStr(child)).value
End Function
Public Function ucJobjectLint(json As Variant, Optional child As Variant) As String
Dim cj As cJobject
Set cj = ucJobjectMake(json)
If Not IsMissing(child) Then
Set cj = cj.child(CStr(child))
End If
ucJobjectLint = cj.serialize(True)
End Function
Public Function cleanGoogleWire(sWire As String) As String
Dim jStart As String, p As Long, newWire As Boolean, e As Long, s As String, reg As RegExp, _
match As match, matches As MatchCollection, v As Double, i As Long, _
year As Long, month As Long, day As Long, hour As Long, min As Long, sec As Long, ms As Long, _
t As cStringChunker, consumed As Long
jStart = "table:"
p = InStr(1, sWire, jStart)
'there have been multiple versions of wire ...
If p = 0 Then
'try the other one
jStart = q & ("table") & q & ":"
p = InStr(1, sWire, jStart)
newWire = True
End If
p = InStr(1, sWire, jStart)
e = Len(sWire) - 1
If p <= 0 Or e <= 0 Or p > e Then
MsgBox " did not find table definition data"
Exit Function
End If
If Mid(sWire, e, 2) <> ");" Then
MsgBox ("incomplete google wire message")
Exit Function
End If
' encode the 'table:' part to a cjobject
p = p + Len(jStart)
s = "{" & jStart & "[" & Mid(sWire, p, e - p - 1) & "]}"
' google protocol doesnt have quotes round the key of key value pairs,
' and i also need to convert date from javascript syntax new Date()
' we'll force it to be a 13 digit timestamp, since cjobject knows how to make that into a date
's = rxReplace("(new\sDate)(\()(\d+)(,)(\d+)(,)(\d+)(\))", s, "'$3/$5/$7'")
'new\s+date\s*\(\s*(\d+)\s*(,\s*\d+)\s*(,\s*\d+)?\s*(,\s*\d+)?\s*(,\s*\d+)?\s*(,\s*\d+)?\s*(,\s*\d+)?\)
Set reg = New RegExp
With reg
.Pattern = "new\s+Date\s*\(\s*(\d+)\s*(,\s*\d+)\s*(,\s*\d+)?\s*(,\s*\d+)?\s*(,\s*\d+)?\s*(,\s*\d+)?\s*(,\s*\d+)?\)"
.Global = True
End With
Set matches = reg.execute(s)
If matches.count > 0 Then
Set t = New cStringChunker
consumed = 0
For Each match In matches
t.add Mid(s, consumed + 1, match.FirstIndex - consumed)
consumed = consumed + match.FirstIndex - consumed
With match
If .SubMatches.count >= 2 And .SubMatches.count <= 7 Then
'these are the only valid number of args to a javascript new Date()
day = 1
hour = 0
min = 0
sec = 0
ms = 0
year = .SubMatches(0)
month = Replace(.SubMatches(1), ",", "") + 1
If .SubMatches.count > 2 And Not IsEmpty(.SubMatches(2)) Then day = Replace(.SubMatches(2), ",", "")
If .SubMatches.count > 3 And Not IsEmpty(.SubMatches(3)) Then hour = Replace(.SubMatches(3), ",", "")
If .SubMatches.count > 4 And Not IsEmpty(.SubMatches(4)) Then min = Replace(.SubMatches(4), ",", "")
If .SubMatches.count > 5 And Not IsEmpty(.SubMatches(5)) Then sec = Replace(.SubMatches(5), ",", "")
If .SubMatches.count > 6 And Not IsEmpty(.SubMatches(6)) Then ms = Replace(.SubMatches(6), ",", "")
' now convert to a date and format
t.add(q) _
.add(CStr(DateSerial(year, month, day) + TimeSerial(hour, min, sec) + CDbl(ms) / 86400)) _
.add (q)
consumed = consumed + match.length
End If
End With
Next match
If consumed < Len(s) Then t.add Mid(s, consumed + 1)
s = t.content
Set t = Nothing
End If
If Not newWire Then s = rxReplace("(\w+)(:)", s, "'$1':")
cleanGoogleWire = s
End Function
Public Function xmlStringToJobject(xmlString As String, Optional complain As Boolean = True) As cJobject
Dim doc As Object
' parse xml
Set doc = createObject("msxml2.DOMDocument")
doc.LoadXML xmlString
If doc.parsed And doc.parseError = 0 Then
Set xmlStringToJobject = docToJobject(doc, complain)
Exit Function
End If
Set xmlStringToJobject = Nothing
If complain Then
MsgBox ("Invalid xml string - xmlparseerror code:" & doc.parseError)
End If
Exit Function
End Function
Public Function docToJobject(doc As Object, Optional complain As Boolean = True) As cJobject
' convert xml document to a cjobject
Dim node As IXMLDOMNode, job As cJobject
Set job = New cJobject
job.init Nothing
Set docToJobject = handleNodes(doc, job)
End Function
Private Function isArrayRoot(parent As IXMLDOMNode) As Boolean
Dim node As IXMLDOMNode, n As Long, node2 As IXMLDOMNode
isArrayRoot = False
If parent.NodeType = NODE_ELEMENT And parent.ChildNodes.length > 1 Then
For Each node2 In parent.ChildNodes
If node2.NodeType = NODE_ELEMENT Then
n = 0
For Each node In parent.ChildNodes
If node.NodeType = NODE_ELEMENT And _
node2.nodeName = node.nodeName Then n = n + 1
Next node
If n > 1 Then
' this shoudl be true, but for leniency i'll comment
'Debug.Assert n = parent.ChildNodes.Length
isArrayRoot = True
Exit Function
End If
End If
Next node2
End If
End Function
Private Function handleNodes(parent As IXMLDOMNode, job As cJobject) As cJobject
Dim node As IXMLDOMNode, joc As cJobject, attrib As IXMLDOMAttribute, i As Long, _
arrayJob As cJobject
If isArrayRoot(parent) Then
' we need an array associated with this this node
' subsequent members will need to make space for themselves
Set joc = job.add(parent.nodeName).addArray
Else
Set joc = handleNode(parent, job)
End If
' deal with any attributes
If Not parent.Attributes Is Nothing Then
For Each attrib In parent.Attributes
handleNode attrib, joc
Next attrib
End If
' do the children
If Not parent.ChildNodes Is Nothing And parent.ChildNodes.length > 0 Then
For Each node In parent.ChildNodes
handleNodes node, joc
Next node
End If
' always return the level at which we arrived
Set handleNodes = job
End Function
Private Function handleNode(node As IXMLDOMNode, job As cJobject, Optional arrayHead As Boolean = False) As cJobject
Dim key As cJobject
'' not a comprehensive convertor
Set handleNode = job
Debug.Print node.nodeName & node.NodeType & node.NodeValue
Select Case node.NodeType
Case NODE_ATTRIBUTE
' we cant have an array of attributes - this will silently use the latest
job.add node.nodeName, node.NodeValue
Case NODE_ELEMENT
If job.isArrayRoot Then
Dim b As Boolean
b = (node.ChildNodes.length = 1)
If (b) Then b = node.ChildNodes(0).NodeType = NODE_TEXT
If (b) Then
Set handleNode = job.add.add
Else
Set handleNode = job.add.add(node.nodeName)
End If
Else
Set handleNode = job.add(node.nodeName)
End If
Case NODE_TEXT
job.value = node.NodeValue
Case NODE_DOCUMENT, NODE_CDATA_SECTION, NODE_ENTITY_REFERENCE, _
NODE_ENTITY, NODE_PROCESSING_INSTRUCTION, NODE_COMMENT, NODE_DOCUMENT_TYPE, _
NODE_DOCUMENT_FRAGMENT, NODE_NOTATION
' just ignore these for now
Case Else
Debug.Assert False
End Select
End Function
Public Function makeSheetFromJob(job As cJobject, sheetName As String) As cDataSet
Dim ds As cDataSet, target As Range, dc As cCell, jo As cJobject
' clear the target sheet
Set ds = New cDataSet
' need something there to load
Set target = Sheets(sheetName).Range("a1")
If IsEmpty(target.value) Then
target.value = "dummy"
End If
ds.load target.Worksheet.name
' create headings based on all data found
makeSheetHeadingsFromJob job, ds
ds.teardown
' now reload with new headings
Set ds = New cDataSet
ds.load (target.Worksheet.name)
' now populate the data
With ds.headingRow
For Each jo In job.children
For Each dc In .headings
If (isSomething(jo.child(dc.value))) Then
.where.Resize(1, 1).Offset(jo.childIndex, dc.column - 1).value = jo.child(dc.value).value
End If
Next dc
If (jo.childIndex Mod 1000 = 0) Then
Debug.Print "done "; jo.childIndex; " rows"
End If
Next jo
End With
' clean
Dim dsnew As cDataSet
Set dsnew = New cDataSet
dsnew.load (ds.name)
ds.teardown
Set makeSheetFromJob = dsnew
End Function
Public Sub makeSheetHeadingsFromJob(jo As cJobject, ds As cDataSet)
Dim jobHead As cJobject, job As cJobject, joc As cJobject, jod As cJobject
Set jobHead = New cJobject
' first step, identify the headings
' this will also take care of situation when each item doesnt have the same children
Set jobHead = jobHead.init(Nothing)
For Each job In jo.children
Set jobHead = rescurseSheetHeadersFromJob(job, jobHead)
Next job
' let's clear all existing
If (isSomething(ds.where)) Then
ds.where.ClearContents
End If
ds.headingRow.where.ClearContents
' now the heading
With firstCell(ds.headingRow.where)
For Each job In jobHead.children
.Offset(, job.childIndex - 1).value = Replace(job.key, "___", ".")
Next job
End With
jobHead.teardown
End Sub
Private Function rescurseSheetHeadersFromJob(job As cJobject, _
jobHead As cJobject, Optional k As String = vbNullString) As cJobject
Dim joc As cJobject, s As String
' the trick here is to collapse to a single depth- we'll replace the underscores with . later
If job.hasChildren Then
If k <> vbNullString Then k = k + "___"
For Each joc In job.children
rescurseSheetHeadersFromJob joc, jobHead, k + joc.key
Next joc
Else
If k = vbNullString Then k = job.key
If (Not IsEmpty(job.value)) Then
jobHead.add k
End If
End If
Set rescurseSheetHeadersFromJob = jobHead
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment