forecast_api/VBA/Utils.bas

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 = 15

    ' align header to body (should be done last!)
    hdr.width = det.width
    hdr.Left = det.Left
    hdr.Top = det.Top - (hdr.Height + 3)

End Sub

Public Function IntersectsWith(Range1 As Range, Range2 As Range) As Boolean
    IntersectsWith = Not Application.Intersect(Range1, Range2) Is Nothing
End Function