How to parse this into a dictionary VBA - vba

Question

I'm working on a project and I'm wondering how I would go about parsing a line like this:
oDesign.ChangeProperty Array("NAME:AllTabs", Array("NAME:LocalVariableTab", Array("NAME:PropServers", "LocalVariables"), Array("NAME:NewProps", Array("NAME:antipad", "PropType:=", "VariableProp", "UserDef:=", true, "Value:=", "40mil")), Array("NAME:ChangedProps", Array("NAME:antipad", "Hidden:=", false))))
into something like this:
oDesign.ChangeProperty(
[
"NAME:AllTabs",
[
"NAME:LocalVariableTab",
[
"NAME:PropServers",
"LocalVariables"
],
[
"NAME:NewProps",
[
"NAME:antipad",
"PropType:=" , "VariableProp",
"UserDef:=" , True,
"Value:=" , "40mil"
]
],
[
"NAME:ChangedProps",
[
"NAME:antipad",
"Hidden:=" , False,
"Value:=" , "40mil"
]
]
]
])
I was thinking about using dictionaries, but I'm not sure how to do this with VBA.
Also, suggestions about indentation are appreciated. I was thinking about using stacks, but I'm sure there are easier ways to do it.

Answer 1

If the goal is to get JSON from this kind of VBA arrays, then this could be a approach:
Sub test()
arr = Array("NAME:AllTabs", Array("NAME:LocalVariableTab", Array("NAME:PropServers", "LocalVariables"), Array("NAME:NewProps", Array("NAME:antipad", "PropType:=", "VariableProp", "UserDef:=", True, "Value:=", "40mil")), Array("NAME:ChangedProps", Array("NAME:antipad", "Hidden:=", False))))
sJSON = "[" & recursiveVBAArrayToJSON(arr, "") & vbLf & "]"
MsgBox sJSON
End Sub
Function recursiveVBAArrayToJSON(arr As Variant, res As String) As String
For i = LBound(arr) To UBound(arr)
If TypeName(arr(i)) = "Variant()" Then
res = res & vbLf & "["
res = recursiveVBAArrayToJSON(arr(i), res)
res = res & vbLf & "]" & IIf(i <> UBound(arr), ",", "")
Else
res = res & vbLf & """" & arr(i) & """" & IIf(i <> UBound(arr), ",", "")
End If
Next
recursiveVBAArrayToJSON = res
End Function

Answer 2

Axel created his solution faster than I created mine and I do not normally post rival solutions unless I think earlier solutions are faulty. Axel's solution does not look faulty but he has not handled indenting (which you specifically mention as important) nor does he concatenate "Xxxx=" with the value. I also think Axel is correct to use recursion rather than collections. However, I decided to post this answer as a possibly interesting alternative.
You can do little with Excel VBA without using the inbuilt collections. However, I rarely have user collections or dictionaries because I do not normally tackle problems big enough to need them in VBA. This requirement looked simple so I thought I would treat it as a training exercise.
My understanding of dictionaries is that a key is compulsory. There are no obvious keys so I have used collections.
The code below is basic. I have performed the minimum of validation and I am sure I could have handled the output in a more elegant manner. I have limited myself to “can it be done?”
I have placed your string in cell A1 of worksheet “Sheet1” as the easiest way of making it available to the macros.
My output does not include the trailing “"Value:=" , "40mil"” because it is not in the input string.
I have handled indenting consistently and I have used a constant so you can easily change the number of spaces. The number of spaces between strings and comma does not seem consistent in your required output so I have made little attempt to match it. However, I see that as a minor detail; the answer to you question is “Yes, your string can be parsed and converted to the output you desire.”
Option Explicit
Enum EVT
DCP
ArrayOpen
ArrayClose
Comma
Str
BoolTrue
BoolFalse
End Enum
Sub Control()
Dim InxOutput As Long
Dim InxToken As Long
Dim Output As New Collection
Dim StrToParse As String
Dim Tokens As New Collection
StrToParse = Worksheets("Sheet1").Cells(1, 1).Value
Call Parse(StrToParse, Tokens)
For InxToken = 1 To Tokens.Count
Debug.Print Tokens.Item(InxToken)
Next
Call CreateOutput(Tokens, Output)
For InxOutput = 1 To Output.Count
Debug.Print Output.Item(InxOutput)
Next
Set Tokens = Nothing
Set Output = Nothing
End Sub
Sub Parse(ByVal Str As String, ByRef Tokens As Collection)
' Str is a string such as: oDesign.ChangeProperty Array("NAME:AllTabs", ...
' On entry, Token must be an empty collection.
' The routine parses Str and creates tokens in Tokens of the form:
' nn¬mm¬xxxxx
' where:
' * nn is the level of the token. 1 for the outer token, oDesign.ChangeProperty,
' and 2, 3 and so on for each nested array or array element
' * ¬ is a separator
' * mm is a enumerator defined by Enum EVT:
' * Enum Indicated token
' * DCP oDesign.ChangeProperty
' * ArrayOpen Array(
' * ArrayClose )
' * Comma ,
' * Str Quoted string
' * BoolTrue true
' * BoolFalse false
' * xxxxx with its preceding ¬ is only present for a quoted string. The value
' of xxxxx is the quoted string without the quotes.
Dim LevelCrnt As Long
Dim PosStrCrnt As Long
Dim PosStrQuote As Long
PosStrCrnt = 1
LevelCrnt = 1
If Mid(Str, PosStrCrnt, 22) <> "oDesign.ChangeProperty" Then
Debug.Assert False
' String does not start as expected
Exit Sub
End If
Tokens.Add LevelCrnt & "¬" & EVT.DCP
LevelCrnt = LevelCrnt + 1
PosStrCrnt = PosStrCrnt + 22
Do While PosStrCrnt < Len(Str)
If Mid(Str, PosStrCrnt, 1) = " " Then
' Step over space
PosStrCrnt = PosStrCrnt + 1
ElseIf Mid(Str, PosStrCrnt, 1) = "," Then
' Comma
Tokens.Add LevelCrnt & "¬" & EVT.Comma
PosStrCrnt = PosStrCrnt + 1
ElseIf Mid(Str, PosStrCrnt, 1) = ")" Then
' End of array
LevelCrnt = LevelCrnt - 1
Tokens.Add LevelCrnt & "¬" & EVT.ArrayClose
PosStrCrnt = PosStrCrnt + 1
ElseIf Mid(Str, PosStrCrnt, 6) = "Array(" Then
' Start of array
Tokens.Add LevelCrnt & "¬" & EVT.ArrayOpen
LevelCrnt = LevelCrnt + 1
PosStrCrnt = PosStrCrnt + 6
ElseIf Mid(Str, PosStrCrnt, 1) = """" Then
' Quoted string
PosStrCrnt = PosStrCrnt + 1
PosStrQuote = InStr(PosStrCrnt, Str, """")
If PosStrQuote = 0 Then
' Unterminated string
Debug.Assert False
Exit Sub
End If
Tokens.Add LevelCrnt & "¬" & EVT.Str & "¬" & Mid(Str, PosStrCrnt, PosStrQuote - PosStrCrnt)
PosStrCrnt = PosStrQuote + 1
ElseIf Mid(Str, PosStrCrnt, 4) = "true" Then
Tokens.Add LevelCrnt & "¬" & EVT.BoolTrue
PosStrCrnt = PosStrCrnt + 4
ElseIf Mid(Str, PosStrCrnt, 5) = "false" Then
Tokens.Add LevelCrnt & "¬" & EVT.BoolFalse
PosStrCrnt = PosStrCrnt + 5
Else
' Unexpected token
Debug.Print PosStrCrnt & ": " & Mid(Str, PosStrCrnt, 20)
Debug.Assert False
Exit Sub
End If
Loop
End Sub
Sub CreateOutput(ByRef Tokens As Collection, ByRef Output As Collection)
' Tokens is a collection of tokens created by Parse
' On entry. Output is an empty collection
' On exit, Output is an human readable version of Tokens
' The routine processes the contents in sequence.
Dim ContinuePending As Boolean
Dim EVTCrnt As Long
Dim InxToken As Long
Dim InxPart As Long
Dim LevelCrnt As Long
Dim Part() As String
Dim Pending As String
Const SpacesPerLevel As Long = 4
Pending = ""
ContinuePending = False
For InxToken = 1 To Tokens.Count
' Split token into components
Part = Split(Tokens.Item(InxToken), "¬")
LevelCrnt = Val(Part(0))
EVTCrnt = Val(Part(1))
Select Case EVTCrnt
Case EVT.DCP
Debug.Assert LevelCrnt = 1
' No indent for level 1
Output.Add ("oDesign.ChangeProperty(")
Case EVT.ArrayOpen
' Ouput [ in line with array's parent
Output.Add (Space((LevelCrnt - 2) * SpacesPerLevel) & "[")
Case EVT.ArrayClose
If Pending <> "" Then
' The final contents of this array have not been output
Output.Add (Space((LevelCrnt - 1) * SpacesPerLevel) & Pending)
Pending = ""
End If
' Ouput ] or ]) in line with array's parent
If InxToken = Tokens.Count Then
' This is the close of the final array. Include closing bracket
Output.Add ("])")
Else
' This may be a nested array with a following comma
Pending = "]"
End If
Case EVT.Comma
' Add to Pending
Pending = Pending & ","
If Not ContinuePending Then
' The next string is not to be added to Pending so output
Output.Add (Space((LevelCrnt - 2) * SpacesPerLevel) & Pending)
Pending = ""
End If
Case EVT.Str
If Pending <> "" Then
' This string is to be appended to previous token
Pending = Pending & " """ & Part(2) & """"
Else
' This is a new string
Pending = """" & Part(2) & """"
End If
If Right(Part(2), 2) = ":=" Then
' The next string is to be appended to this one
ContinuePending = True
' Add some spaces before comma
Pending = Pending & " "
Else
ContinuePending = False
' Don't output in case comma is to be appended
End If
Case BoolTrue
If Pending <> "" Then
' This string is to be appended to previous token
Pending = Pending & " ""True"""
Else
' This is a new string
Pending = """True"""
End If
' True cannot be continued but there may be a following comma
ContinuePending = False
Case BoolFalse
If Pending <> "" Then
' This string is to be appended to previous token
Pending = Pending & " ""False"""
Else
' This is a new string
Pending = """False"""
End If
' False cannot be continued but there may be a following comma
ContinuePending = False
End Select
Next
If Pending <> "" Then
' Final output
Output.Add Pending
Pending = ""
End If
End Sub