include Phils new modules

VBA/JsonDebugPrint.bas

@@ -0,0 +1,43 @@
+Attribute VB_Name = "JsonDebugPrint"
+Option Explicit
+
+
+Public Sub TestPrintJSON()
+    PrintJSON ParseJSON("[1,2,3]")
+    PrintJSON ParseJSON("[{""a"":123,""b"":[56,7,78]}]")
+End Sub
+
+' This is definitely NOT a pretty printer. It was written merely as a debugging
+' tool to make sense of the objects that come out of JsonConverter.ParseJSON.
+' It doesn't format in the best way possible, but it does provide a semi-readable
+' view of the data in the JSON object.
+'                                               Phil Runninger 3/1/2023
+'
+Public Sub PrintJSON(obj As Variant, Optional level As Integer = 0)
+    Dim itm As Variant
+    Dim first As Boolean
+    Select Case TypeName(obj)
+        Case "Dictionary"
+            Debug.Print String(level * 2, " "); "{"
+            first = True
+            For Each itm In obj
+                If Not first Then Debug.Print String((level + 1) * 2, " "); ","
+                first = False
+                Debug.Print String((level + 1) * 2, " "); itm; ":";
+                PrintJSON obj(itm), level + 1
+            Next
+            Debug.Print String(level * 2, " "); "}"
+        Case "Collection"
+            Debug.Print String(level * 2, " "); "["
+            first = True
+            For Each itm In obj
+                If Not first Then Debug.Print String(level * 2, " "); ","
+                first = False
+                PrintJSON itm, level + 1
+            Next
+            Debug.Print String(level * 2, " "); "]"
+        Case Else
+            Debug.Print String(level * 2, " "); obj;
+    End Select
+End Sub
+

VBA/Utils.bas

@@ -0,0 +1,618 @@
+Attribute VB_Name = "Utils"
+Option Explicit
+
+Public ADOo_errstring As String
+
+Public Function TBLp_Aggregate(ByRef tbl() As String, ByRef needsort As Boolean, ByRef headers As Boolean, ByRef del_unused As Boolean, ParamArray groupnum_type_sumnum()) As Boolean
+
+    Dim i As Long
+    Dim j As Long
+    Dim nt() As String
+    Dim keep() As Integer
+
+    If needsort Then
+        If Not TBLp_BubbleSortAsc(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetStringArray(1, groupnum_type_sumnum), headers) Then
+            TBLp_Aggregate = False
+            Exit Function
+        End If
+    End If
+
+    If Not TBLp_Roll(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetIntegerArray(2, groupnum_type_sumnum), headers) Then
+        TBLp_Aggregate = False
+        Exit Function
+    End If
+
+
+    If del_unused Then
+        keep = PAp_2DGetMultIntegerArray(ARRAYp_MakeInteger(0, 2), groupnum_type_sumnum)
+        ReDim nt(UBound(keep()), UBound(tbl, 2))
+        For i = 0 To UBound(keep())
+            For j = 0 To UBound(tbl, 2)
+                nt(i, j) = tbl(keep(i), j)
+            Next j
+        Next i
+        tbl = nt
+    End If
+
+    TBLp_Aggregate = True
+
+End Function
+
+Function TBLp_BubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) As Boolean
+
+On Error GoTo errh
+    'get fort field numbers
+    'loop through each row and generate the row key
+    'eveluate the row key against other row keys
+    'perform swaps
+
+    Dim i As Long
+    Dim j As Long
+    Dim k As Long
+
+    k = 0
+    If headers Then k = 1
+
+    For i = k To UBound(tbl, 2) - 1
+        For j = i + 1 To UBound(tbl, 2)
+            If ROWe_AscSwapFlag(tbl, i, j, sortflds, typeflds) Then
+                Call ROWp_Swap(tbl, i, j)
+            Else
+                If ADOo_errstring <> "" Then
+                    TBLp_BubbleSortAsc = False
+                    Exit Function
+                End If
+            End If
+        Next j
+    Next i
+
+errh:
+    If Err.Number <> 0 Then
+        MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description)
+        ADOo_errstring = Err.Description
+    End If
+
+    TBLp_BubbleSortAsc = True
+
+End Function
+
+Public Function TBLp_Roll(ByRef tbl() As String, ByRef gflds() As Integer, ByRef sflds() As Integer, ByRef headers As Boolean) As Boolean
+
+On Error GoTo errh
+    Dim i As Long 'indexes primary row
+    Dim j As Long 'indexes secondary chaecker row
+    Dim k As Integer 'used to start at 0 or 1
+    Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1
+
+    k = 0
+    If headers Then k = 1
+    m = k
+    For i = k To UBound(tbl, 2)
+        If i = UBound(tbl, 2) Then
+            i = i
+        End If
+        j = i + 1
+        Do
+            If j > UBound(tbl, 2) Then Exit Do
+            If ROWe_MatchesFlag(tbl, i, j, gflds) Then
+                Call ROWp_Aggregate2Rows(tbl, i, j, sflds)
+            Else
+                Exit Do
+            End If
+            j = j + 1
+            If j > UBound(tbl, 2) Then
+                Exit Do
+            End If
+        Loop
+        Call ROWp_Copy(tbl, i, m)
+        m = m + 1
+        i = j - 1
+    Next i
+
+    ReDim Preserve tbl(UBound(tbl, 1), m - 1)
+
+errh:
+    If Err.Number <> 0 Then
+        ADOo_errstring = Err.Description
+        TBLp_Roll = False
+        Exit Function
+    End If
+
+    TBLp_Roll = True
+
+End Function
+
+Sub ROWp_Swap(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long)
+
+    Dim temprow() As String
+    ReDim temprow(UBound(tbl, 1))
+    Dim i As Integer
+
+    For i = 0 To UBound(tbl, 1)
+        temprow(i) = tbl(i, p2)
+    Next i
+
+    For i = 0 To UBound(tbl, 1)
+        tbl(i, p2) = tbl(i, p1)
+    Next i
+
+    For i = 0 To UBound(tbl, 1)
+        tbl(i, p1) = temprow(i)
+    Next i
+
+End Sub
+
+Sub ROWp_Copy(ByRef tbl() As String, ByRef r_from As Long, ByRef r_to As Long)
+
+    Dim i As Integer
+
+    For i = 0 To UBound(tbl, 1)
+        tbl(i, r_to) = tbl(i, r_from)
+    Next i
+
+End Sub
+
+Sub ROWp_Aggregate2Rows(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long, ByRef sflds() As Integer)
+
+    Dim i As Integer
+    On Error GoTo exitsub
+    For i = 0 To UBound(sflds, 1)
+        tbl(sflds(i), p1) = CDbl(tbl(sflds(i), p1)) + CDbl(tbl(sflds(i), p2))
+    Next i
+
+exitsub:
+
+End Sub
+
+Function ROWe_AscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer, ByRef TypeFld() As String) As Boolean
+    'only returns true if greater than
+
+On Error GoTo errh
+    Dim i As Integer
+    Dim compare As Integer
+
+    For i = 0 To UBound(KeyFld)
+        Select Case TypeFld(i)
+            Case "S"
+                compare = MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2)))
+            Case "N"
+                compare = MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2)))
+            Case "D"
+                compare = MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2)))
+        End Select
+        Select Case compare
+            Case -1
+                ROWe_AscSwapFlag = True
+                Exit Function
+            Case 1
+                ROWe_AscSwapFlag = False
+                Exit Function
+        End Select
+    Next i
+
+errh:
+    If Err.Number <> 0 Then
+        MsgBox ("Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description)
+        ADOo_errstring = Err.Description
+        Exit Function
+    End If
+
+End Function
+
+Function ROWe_MatchesFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean
+    'only returns true if greater than
+
+    Dim i As Integer
+    Dim k1 As String
+    Dim k2 As String
+
+    For i = 0 To UBound(KeyFld())
+        k1 = k1 & tbl(KeyFld(i), row1)
+    Next i
+
+    For i = 0 To UBound(KeyFld())
+        k2 = k2 & tbl(KeyFld(i), row2)
+    Next i
+
+
+    If k2 = k1 Then
+        ROWe_MatchesFlag = True
+    Else
+        ROWe_MatchesFlag = False
+    End If
+
+End Function
+
+Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ByRef zerobase As Boolean)
+
+    Dim sh As Worksheet
+    Dim address As String
+    Set sh = Sheets(sheet)
+
+    'If clear Then sh.Cells.clear
+    'If transpose Then Call ARRAYp_Transpose(tbl)
+    If zerobase Then
+        address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address
+    Else
+        address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1) - 1, col + UBound(tbl, 2) - 1).address
+    End If
+    sh.Range(address).FormulaR1C1 = tbl
+
+    On Error GoTo errhndl
+
+
+errhndl:
+    If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description)
+
+
+End Sub
+
+Function ARRAYp_TransposeVar(ByRef a() As Variant) As Variant()
+
+    Dim s() As Variant
+    ReDim s(UBound(a, 2), UBound(a, 1))
+
+    Dim i As Long
+    Dim j As Long
+
+    For i = 0 To UBound(s, 1)
+        For j = 0 To UBound(s, 2)
+            s(i, j) = a(j, i)
+        Next j
+    Next i
+
+    ARRAYp_TransposeVar = s
+
+End Function
+
+Function ARRAYp_zerobased_addheader(ByRef z() As Variant, ParamArray cols()) As Variant()
+
+    Dim i As Long
+    Dim j As Long
+
+    Dim r() As Variant
+    ReDim r(UBound(z, 1), UBound(z, 2) + 1)
+
+    For i = 0 To UBound(r, 1)
+        For j = 1 To UBound(r, 2)
+            r(i, j) = z(i, j - 1)
+        Next j
+        r(i, 0) = cols(i)
+    Next i
+
+    ARRAYp_zerobased_addheader = r
+
+End Function
+
+Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String()
+
+    Dim i As Long
+    Dim j As Long
+    Dim table() As String
+    Dim sh As Worksheet
+    Set sh = Sheets(sheet)
+
+    On Error GoTo errhdnl
+
+    i = 1
+    While sh.Cells(row, col + i - 1) <> ""
+        i = i + 1
+    Wend
+
+    j = 1
+    While sh.Cells(row + j - 1, col) <> ""
+        j = j + 1
+    Wend
+
+    ReDim table(i - 2, j - 2)
+    i = 1
+    While i <= UBound(table, 1) + 1
+        j = 0
+        While j <= UBound(table, 2)
+            table(i - 1, j) = sh.Cells(row + j, col + i - 1)
+            j = j + 1
+        Wend
+        i = i + 1
+    Wend
+
+errhdnl:
+    If Err.Number <> 0 Then
+        MsgBox (Err.Description)
+    End If
+
+    SHTp_Get = table
+
+End Function
+
+Function PAp_2DGetStringArray(ByRef index As Integer, ParamArray pa()) As String()
+
+    Dim str() As String
+    Dim i As Long
+    ReDim str(UBound(pa(0)(index)))
+
+    For i = 0 To UBound(pa(0)(index))
+        str(i) = pa(0)(index)(i)
+    Next i
+    PAp_2DGetStringArray = str
+
+End Function
+
+Function PAp_2DGetIntegerArray(ByRef index As Integer, ParamArray pa()) As Integer()
+
+    Dim str() As Integer
+    Dim i As Long
+    If UBound(pa(0)(index)) <> -1 Then
+        ReDim str(UBound(pa(0)(index)))
+
+        For i = 0 To UBound(pa(0)(index))
+            str(i) = pa(0)(index)(i)
+        Next i
+    End If
+    PAp_2DGetIntegerArray = str
+
+End Function
+
+Function PAp_2DGetMultIntegerArray(ByRef ArraysGet() As Integer, ParamArray pa()) As Integer()
+
+    Dim str() As Integer
+    Dim i As Long
+    Dim j As Long
+    Dim cnt As Long
+    Dim index As Long
+
+
+    'get length of selected arrays
+    For i = 0 To UBound(ArraysGet, 1)
+        cnt = cnt + UBound(pa(0)(ArraysGet(i)))
+    Next i
+
+    ReDim str(cnt + 1)
+    cnt = 0
+
+    For i = 0 To UBound(ArraysGet, 1)
+        For j = 0 To UBound(pa(0)(ArraysGet(i)))
+            str(cnt) = pa(0)(ArraysGet(i))(j)
+            cnt = cnt + 1
+        Next j
+    Next i
+
+    PAp_2DGetMultIntegerArray = str
+
+End Function
+
+Public Function ARRAYp_MakeInteger(ParamArray items()) As Integer()
+
+    Dim x() As Integer
+    Dim i As Integer
+    ReDim x(UBound(items))
+
+    For i = 0 To UBound(items())
+        x(i) = items(i)
+    Next i
+
+    ARRAYp_MakeInteger = x
+
+End Function
+
+Public Function MISCe_CompareString(ByRef base As String, ByRef compare As String) As Integer
+
+    If compare < base Then
+        MISCe_CompareString = -1
+        Exit Function
+    End If
+
+    If compare = base Then
+        MISCe_CompareString = 0
+        Exit Function
+    End If
+
+    If compare > base Then
+        MISCe_CompareString = 1
+        Exit Function
+    End If
+
+End Function
+
+Public Function MISCe_CompareDouble(ByRef base As Double, ByRef compare As Double) As Integer
+
+    If compare < base Then
+        MISCe_CompareDouble = -1
+        Exit Function
+    End If
+
+    If compare = base Then
+        MISCe_CompareDouble = 0
+        Exit Function
+    End If
+
+    If compare > base Then
+        MISCe_CompareDouble = 1
+        Exit Function
+    End If
+
+End Function
+
+Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As Integer
+
+
+    If compare < base Then
+        MISCe_CompareDate = -1
+        Exit Function
+    End If
+
+    If compare = base Then
+        MISCe_CompareDate = 0
+        Exit Function
+    End If
+
+    If compare > base Then
+        MISCe_CompareDate = 1
+        Exit Function
+    End If
+
+End Function
+
+Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
+
+
+    Dim ajson As String
+    Dim json As String
+    Dim r As Integer
+    Dim c As Integer
+    Dim needs_comma As Boolean
+    Dim needs_braces As Integer
+
+    needs_comma = False
+    needs_braces = 0
+    ajson = ""
+
+    For r = 2 To UBound(tbl, 1)
+        For c = 1 To UBound(tbl, 2)
+            If tbl(r, c) <> "" Then
+                needs_braces = needs_braces + 1
+                If needs_comma Then json = json & ","
+                needs_comma = True
+                If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
+                    json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c)
+                Else
+                    'test if item is a json object
+                    If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
+                        json = json & """" & tbl(1, c) & """" & ":" & tbl(r, c)
+                    Else
+                        json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
+                    End If
+                End If
+            End If
+        Next c
+        If needs_braces > 0 Then json = "{" & json & "}"
+        needs_comma = False
+        needs_braces = 0
+        If r > 2 Then
+            ajson = ajson & "," & json
+        Else
+            ajson = json
+        End If
+        json = ""
+    Next r
+
+    'if theres more the one record, include brackets for array
+    'if an array_label is given give the array a key and the array become the value
+    'then if the array is labeled with a key it should have braces unless specified otherwise
+    If r > 3 Then
+        ajson = "[" & ajson & "]"
+        If array_label <> "" Then
+            ajson = """" & array_label & """:" & ajson
+            If Not strip_braces Then
+                ajson = "{" & ajson & "}"
+            End If
+        End If
+    Else
+        If strip_braces Then
+            ajson = Mid(ajson, 2, Len(ajson) - 2)
+        End If
+    End If
+
+    json_from_table = ajson
+
+End Function
+
+Public Function json_from_table_zb(ByRef tbl() As Variant, ByRef array_label As String, ByVal force_array As Boolean, Optional strip_braces As Boolean) As String
+
+    Dim ajson As String
+    Dim json As String
+    Dim r As Integer
+    Dim c As Integer
+    Dim needs_comma As Boolean
+    Dim needs_braces As Integer
+
+    needs_comma = False
+    needs_braces = 0
+    ajson = ""
+
+    For r = 1 To UBound(tbl, 1)
+        For c = 0 To UBound(tbl, 2)
+            If tbl(r, c) <> "" Then
+                needs_braces = needs_braces + 1
+                If needs_comma Then json = json & ","
+                needs_comma = True
+                If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
+                    json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & tbl(r, c)
+                Else
+                    'test if item is a json object
+                    If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
+                        json = json & """" & tbl(0, c) & """" & ":" & tbl(r, c)
+                    Else
+                        json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
+                    End If
+                End If
+            End If
+        Next c
+        If needs_braces > 0 Then json = "{" & json & "}"
+        needs_comma = False
+        needs_braces = 0
+        If r > 1 Then
+            ajson = ajson & "," & json
+        Else
+            ajson = json
+        End If
+        json = ""
+    Next r
+
+    'if theres more the one record, include brackets for array
+    'if an array_label is given give the array a key and the array become the value
+    'then if the array is labeled with a key it should have braces unless specified otherwise
+    If r > 2 Or force_array Then
+        ajson = "[" & ajson & "]"
+        If array_label <> "" Then
+            ajson = """" & array_label & """:" & ajson
+            If Not strip_braces Then
+                ajson = "{" & ajson & "}"
+            End If
+        End If
+    Else
+        If strip_braces Then
+            ajson = Mid(ajson, 2, Len(ajson) - 2)
+        End If
+    End If
+
+    json_from_table_zb = ajson
+
+End Function
+
+Public Function SHTp_get_block(point As Range) As Variant()
+
+    SHTp_get_block = point.CurrentRegion
+
+End Function
+
+Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols())
+
+    Dim i As Long
+
+    hdr.ColumnCount = det.ColumnCount
+    hdr.ColumnWidths = det.ColumnWidths
+
+    ' add header elements
+    hdr.clear
+    hdr.AddItem
+    For i = 0 To UBound(cols, 1)
+        hdr.list(0, i) = cols(i)
+    Next i
+
+    ' make it pretty
+    'body.ZOrder (1)
+    'lbHEAD.ZOrder (0)
+    hdr.SpecialEffect = fmSpecialEffectFlat
+    'hdr.BackColor = RGB(200, 200, 200)
+    hdr.Height = 10
+
+    ' align header to body (should be done last!)
+    hdr.width = det.width
+    hdr.Left = det.Left
+    hdr.Top = det.Top - (hdr.Height - 1)
+
+End Sub
+
+
+
+