excel vba customxml cdata code example

Example 1: excel vba json parser

'-----------------------------------------------------------------------------------
' VBA JSON Parser
'-----------------------------------------------------------------------------------
Option Explicit
Private p&, token, dic

Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function

Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If
                
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function

Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function



'-----------------------------------------------------------------------------------
' Support Functions
'-----------------------------------------------------------------------------------
Function Tokenize(s$)
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function

Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .Global = bGlobal
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = Pattern
    If .TEST(s) Then
      Set m = .Execute(s)
      ReDim v(1 To m.Count)
      For Each n In m
        c = c + 1
        v(c) = n.value
        If bGroup1Bias Then If Len(n.submatches(0)) Or n.value = """""" Then v(c) = n.submatches(0)
      Next
    End If
  End With
  RExtract = v
End Function

Function ArrayID$(e)
    ArrayID = "(" & e & ")"
End Function

Function ReducePath$(key$)
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1)
End Function

Example 2: excel vba >>>

'Many programming languages have a bitwise zero-fill right-shift operator: >>>
'VBA does not. However, it can be emulated in a performant function:

Public Function ShiftRightZeroFill&(ByVal n&, Optional ByVal shifts& = 1)
    Dim d&
    If shifts = 0 Then ShiftRightZeroFill = n: Exit Function
    If n And &H80000000 Then
        shifts = shifts - 1
        n = (n And &H7FFFFFFF) \ 2 Or &H40000000
    End If
    Select Case shifts
        Case 0:  d = n
        Case 1:  d = n \ 2&
        Case 2:  d = n \ 4&
        Case 3:  d = n \ 8&
        Case 4:  d = n \ 16&
        Case 5:  d = n \ 32&
        Case 6:  d = n \ 64&
        Case 7:  d = n \ 128&
        Case 8:  d = n \ 256&
        Case 9:  d = n \ 512&
        Case 10: d = n \ 1024&
        Case 11: d = n \ 2048&
        Case 12: d = n \ 4096&
        Case 13: d = n \ 8192&
        Case 14: d = n \ 16384&
        Case 15: d = n \ 32768
        Case 16: d = n \ 65536
        Case 17: d = n \ 262144
        Case 18: d = n \ 262144
        Case 19: d = n \ 524288
        Case 20: d = n \ 1048576
        Case 21: d = n \ 2097152
        Case 22: d = n \ 4194304
        Case 23: d = n \ 8388608
        Case 24: d = n \ 16777216
        Case 25: d = n \ 33554432
        Case 26: d = n \ 67108864
        Case 27: d = n \ 134217728
        Case 28: d = n \ 268435456
        Case 29: d = n \ 536870912
        Case 30: d = n \ 1073741824
        Case 31: d = &H0&
    End Select
    ShiftRightZeroFill = d
End Function
    
'----------------------------------------------------------------------------    
    
'Don't be off-put at the size of the function. This is many times faster than 
'any other VBA function that carries out bitwise zero-filled right-shfits.
'The hard-coded values are much faster than calculating with exponentiation.

MsgBox ShiftRightZeroFill&(-9, 2)		<--displays:  1073741821
    

'NB: Remember that VBA Longs are signed.