diff --git a/VBA/JsonDebugPrint.bas b/VBA/JsonDebugPrint.bas new file mode 100644 index 0000000..93d29db --- /dev/null +++ b/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 + diff --git a/VBA/Utils.bas b/VBA/Utils.bas new file mode 100644 index 0000000..b79c52c --- /dev/null +++ b/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 + + + +