change version to b23

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
+
+
+
+

VBA/Windows_API.cls

@@ -0,0 +1,247 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Windows_API"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
+Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
+Private Declare PtrSafe Function GetClipboardOwner Lib "user32" () As LongPtr
+Private Declare PtrSafe Function SetClipboardViewer Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
+Private Declare PtrSafe Function GetClipboardViewer Lib "user32" () As LongPtr
+Private Declare PtrSafe Function ChangeClipboardChain Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndNext As LongPtr) As Long
+Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
+Private Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
+Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
+Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
+Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
+Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _
+    (ByVal wFormat As Long, _
+    ByVal lpString As String, _
+    ByVal nMaxCount As Long) As Long
+Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
+Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
+Private Declare PtrSafe Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
+Private Declare PtrSafe Function GetOpenClipboardWindow Lib "user32" () As LongPtr
+Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" _
+    (ByVal lpszSrc As String, _
+     ByVal lpszDst As String) As Long
+Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
+Private Declare PtrSafe Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" _
+    (ByVal lpszSrc As String, _
+    ByVal lpszDst As String, _
+    ByVal cchDstLength As Long) As Long
+Private Declare PtrSafe Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" _
+    (ByVal lpszSrc As String, _
+    ByVal lpszDst As String, _
+    ByVal cchDstLength As Long) As Long
+Private Declare PtrSafe Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String
+Private Declare PtrSafe Function CharUpperBuff Lib "user32" Alias "CharUpperBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
+Private Declare PtrSafe Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String
+Private Declare PtrSafe Function CharLowerBuff Lib "user32" Alias "CharLowerBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
+Private Declare PtrSafe Function CharNext Lib "user32" Alias "CharNextA" (ByVal lpsz As String) As String
+Private Declare PtrSafe Function CharPrev Lib "user32" Alias "CharPrevA" (ByVal lpszStart As String, ByVal lpszCurrent As String) As String
+Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
+Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
+Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
+Private Declare PtrSafe Function GlobalHandle Lib "kernel32" (wMem As Any) As LongPtr
+Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
+Private Declare PtrSafe Function GlobalReAlloc Lib "kernel32" (ByVal hMem As LongPtr, ByVal dwBytes As LongPtr, ByVal wFlags As Long) As LongPtr
+Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
+Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
+Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _
+    (ByRef lpMsg As MSG, ByVal hwnd As Long, _
+     ByVal wMsgFilterMin As Long, _
+     ByVal wMsgFilterMax As Long, _
+     ByVal wRemoveMsg As Long) As Long
+Private Declare PtrSafe Function TranslateMessage Lib "user32" _
+    (ByRef lpMsg As MSG) As Long
+Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
+    (ByVal hwnd As Long, _
+     ByVal wMsg As Long, _
+     ByVal wParam As Long, _
+     lParam As Any) As Long
+Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
+    (ByVal lpClassName As String, _
+     ByVal lpWindowName As String) As Long
+
+
+
+Private Type POINTAPI
+    x As Long
+    Y As Long
+End Type
+
+Private Type MSG
+    hwnd As Long
+    Message As Long
+    wParam As Long
+    lParam As Long
+    time As Long
+    pt As POINTAPI
+End Type
+
+Private Const WM_KEYDOWN As Long = &H100
+Private Const PM_REMOVE  As Long = &H1
+Private Const WM_CHAR    As Long = &H102
+Private Const GHND As Long = &H42
+Private Const CF_TEXT = 1
+Private Const MAXSIZE = 40096
+Private bExitLoop As Boolean
+
+
+
+Public Sub SetClipboard(sUniText As String)
+    Dim iStrPtr As LongPtr
+    Dim iLen As LongPtr
+    Dim iLock As LongPtr
+    Const GMEM_MOVEABLE As Long = &H2
+    Const GMEM_ZEROINIT As Long = &H40
+    Const CF_UNICODETEXT As Long = &HD
+    OpenClipboard 0&
+    EmptyClipboard
+    iLen = LenB(sUniText) + 2&
+    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
+    iLock = GlobalLock(iStrPtr)
+    lstrcpy iLock, StrPtr(sUniText)
+    GlobalUnlock iStrPtr
+    SetClipboardData CF_UNICODETEXT, iStrPtr
+    CloseClipboard
+End Sub
+
+Public Sub ClipBoard_SetData(sUniText As String)
+
+    
+    Dim hGlobalMemory As LongPtr
+    Dim lpGlobalMemory As LongPtr
+    Dim hClipMemory As LongPtr
+    Dim x As Long
+    
+    hGlobalMemory = GlobalAlloc(GHND, Len(sUniText) + 1)
+    
+    lpGlobalMemory = GlobalLock(hGlobalMemory)
+    
+    lpGlobalMemory = lstrcpy(lpGlobalMemory, sUniText)
+    
+    If GlobalUnlock(hGlobalMemory) <> 0 Then
+        GoTo OutOfHere2
+    End If
+    
+    If OpenClipboard(0&) = 0 Then
+        Exit Sub
+    End If
+    
+    x = EmptyClipboard()
+    
+    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
+    
+OutOfHere2:
+    
+    If CloseClipboard() = 0 Then
+        MsgBox ("ruh-roh")
+    End If
+
+End Sub
+
+Public Function GetClipboard() As String
+    Dim iStrPtr As Long
+    Dim iLen As Long
+    Dim iLock As Long
+    Dim sUniText As String
+    Const CF_UNICODETEXT As Long = 13&
+    OpenClipboard 0&
+    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
+        iStrPtr = GetClipboardData(CF_UNICODETEXT)
+        If iStrPtr Then
+            iLock = GlobalLock(iStrPtr)
+            iLen = GlobalSize(iStrPtr)
+            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
+            lstrcpy StrPtr(sUniText), iLock
+            GlobalUnlock iStrPtr
+        End If
+        GetClipboard = sUniText
+    End If
+    CloseClipboard
+End Function
+
+
+Sub TrackKeyPressInit()
+
+    Dim msgMessage As MSG
+    Dim bCancel As Boolean
+    Dim iKeyCode As Integer
+    Dim lXLhwnd As Long
+
+    On Error GoTo errHandler:
+        Application.EnableCancelKey = xlErrorHandler
+        'initialize this boolean flag.
+        bExitLoop = False
+        'get the app hwnd.
+        lXLhwnd = FindWindow("XLMAIN", Application.Caption)
+    Do
+        WaitMessage
+        'check for a key press and remove it from the msg queue.
+        If PeekMessage _
+            (msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
+            'strore the virtual key code for later use.
+            iKeyCode = msgMessage.wParam
+           'translate the virtual key code into a char msg.
+            TranslateMessage msgMessage
+            PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
+            WM_CHAR, PM_REMOVE
+           'for some obscure reason, the following
+          'keys are not trapped inside the event handler
+            'so we handle them here.
+            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
+            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
+           'assume the cancel argument is False.
+            bCancel = False
+            'the VBA RaiseEvent statement does not seem to return ByRef arguments
+            'so we call a KeyPress routine rather than a propper event handler.
+            Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
+            'if the key pressed is allowed post it to the application.
+            If bCancel = False Then
+                PostMessage _
+                lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
+            End If
+        End If
+errHandler:
+        'allow the processing of other msgs.
+        DoEvents
+    Loop Until bExitLoop
+
+End Sub
+
+Sub StopKeyWatch()
+
+    'set this boolean flag to exit the above loop.
+    bExitLoop = True
+
+End Sub
+
+
+'\\This example illustrates how to catch worksheet
+'\\Key strokes in order to prevent entering numeric
+'\\characters in the Range "A1:D10" .
+Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, ByVal Target As Range, Cancel As Boolean)
+
+    Const MSG As String = "Numeric Characters are not allowed in" & vbNewLine & "the Range:  """
+    Const TITLE As String = "Invalid Entry !"
+
+    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
+        If Chr(KeyAscii) Like "[0-9]" Then
+            MsgBox MSG & Range("A1:D10").address(False, False) _
+            & """ .", vbCritical, TITLE
+            Cancel = True
+        End If
+    End If
+
+End Sub
+
+
+

VBA/build.frm

@@ -0,0 +1,81 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build 
+   Caption         =   "UserForm1"
+   ClientHeight    =   3015
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   8100
+   OleObjectBlob   =   "build.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "build"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Public part As String
+Public bill As String
+Public ship As String
+Public useval As Boolean
+Option Explicit
+
+
+
+
+Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
+    Select Case KeyCode
+        Case 13
+            useval = True
+            Me.Hide
+        Case 27
+            useval = False
+            Me.Hide
+    End Select
+End Sub
+
+
+Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
+
+    Select Case KeyCode
+        Case 13
+            useval = True
+            Me.Hide
+        Case 27
+            useval = False
+            Me.Hide
+    End Select
+
+End Sub
+
+
+Private Sub cbShip_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
+    Select Case KeyCode
+        Case 13
+            useval = True
+            Me.Hide
+        Case 27
+            useval = False
+            Me.Hide
+    End Select
+End Sub
+
+Private Sub UserForm_Activate()
+    
+    useval = False
+    
+    cbPart.value = part
+    cbBill.value = bill
+    cbShip.value = ship
+    
+    cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A2").CurrentRegion)
+    'cbPart.list(1).Remove
+    cbBill.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
+    'cbPart.list(1).Remove
+    cbShip.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
+    'cbPart.list(1).Remove
+    
+
+End Sub
+
+
+

VBA/changes.frm

@@ -0,0 +1,134 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes 
+   Caption         =   "History"
+   ClientHeight    =   7785
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   16710
+   OleObjectBlob   =   "changes.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "changes"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private x As Variant
+
+Private Sub cbCancel_Click()
+
+    Me.Hide
+
+End Sub
+
+Private Sub cbUndo_Click()
+
+    
+    Call Me.delete_selected
+
+End Sub
+
+Private Sub lbHist_Change()
+
+    Dim i As Integer
+
+    For i = 0 To Me.lbHist.ListCount - 1
+        If Me.lbHist.Selected(i) Then
+            Me.tbPrint.value = x(i, 7)
+            Exit Sub
+        End If
+    Next i
+
+End Sub
+
+
+
+Private Sub lbHist_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
+
+    Select Case KeyCode
+        Case 46
+            Call Me.delete_selected
+        Case 27
+            Call Me.Hide
+    End Select
+
+End Sub
+
+
+
+Private Sub tbPrint_Change()
+
+End Sub
+
+
+Private Sub UserForm_Activate()
+
+    Dim fail As Boolean
+    
+    'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail)
+    x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & Sheets("data").Cells(2, 5) & """}}", fail)
+    If fail Then
+        Me.Hide
+        Exit Sub
+    End If
+    Me.lbHist.list = x
+    
+    lbHEAD.ColumnCount = lbHist.ColumnCount
+    lbHEAD.ColumnWidths = lbHist.ColumnWidths
+
+    ' add header elements
+    lbHEAD.clear
+    lbHEAD.AddItem
+    lbHEAD.list(0, 0) = "Modifier"
+    lbHEAD.list(0, 1) = "Owner"
+    lbHEAD.list(0, 2) = "When"
+    lbHEAD.list(0, 3) = "Tag"
+    lbHEAD.list(0, 4) = "Comment"
+    lbHEAD.list(0, 5) = "Sales"
+    lbHEAD.list(0, 6) = "id"
+    Dim tbo As New TheBigOne
+    Call tbo.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
+    
+    
+    ' make it pretty
+    'body.ZOrder (1)
+    'lbHEAD.ZOrder (0)
+    'lbHEAD.SpecialEffect = fmSpecialEffectFlat
+    'lbHEAD.BackColor = RGB(200, 200, 200)
+    'lbHEAD.Height = 10
+
+    ' align header to body (should be done last!)
+    'lbHEAD.width = lbHist.width
+    'lbHEAD.Left = lbHist.Left
+    'lbHEAD.Top = lbHist.Top - (lbHEAD.Height - 1)
+
+End Sub
+
+Sub delete_selected()
+
+    Dim logid As Integer
+    Dim i As Integer
+    Dim fail As Boolean
+    Dim proceed As Boolean
+    
+    If MsgBox("Permanently delete these changes?", vbOKCancel) = vbCancel Then
+        Exit Sub
+    End If
+    
+    
+    For i = 0 To Me.lbHist.ListCount - 1
+        If Me.lbHist.Selected(i) Then
+            Call handler.undo_changes(x(i, 6), fail)
+            If fail Then
+                MsgBox ("undo did not work")
+                Exit Sub
+            End If
+        End If
+    Next i
+    
+    Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
+    
+    Me.lbHist.clear
+    Me.Hide
+
+End Sub

VBA/handler.bas

@@ -0,0 +1,643 @@
+Attribute VB_Name = "handler"
+Option Explicit
+
+Public sql As String
+Public jsql As String
+Public scenario As String
+Public sc() As Variant
+Public x As New TheBigOne
+Public wapi As New Windows_API
+Public data() As String
+Public agg() As String
+Public showprice As Boolean
+Public server As String
+Public plan As String
+Public basis() As Variant
+Public baseline() As Variant
+Public adjust() As Variant
+
+
+Sub load_fpvt()
+
+    Application.StatusBar = "retrieving selection data....."
+    
+    'data = x.SHTp_Get("data", 1, 1, True)
+    'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30))
+    Dim i As Long
+    Dim s_tot As Object
+    
+    fpvt.lbSDET.list = handler.sc
+    
+    showprice = False
+    
+    For i = 0 To UBound(handler.sc, 1)
+        If handler.sc(i, 0) = "part_descr" Then
+            showprice = True
+            Exit For
+        End If
+    Next i
+       
+    
+    fpvt.Show
+     
+
+
+End Sub
+
+Function scenario_package(doc As String, ByRef status As Boolean) As Object
+
+    Dim req As New WinHttp.WinHttpRequest
+    Dim json As Object
+    Dim wr As String
+    
+    On Error GoTo errh
+    
+    With req
+        .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
+        .Open "GET", server & "/scenario_package", True
+        .SetRequestHeader "Content-Type", "application/json"
+        .Send doc
+        .WaitForResponse
+        wr = .ResponseText
+    End With
+
+    Set json = JsonConverter.ParseJson(wr)
+    Set scenario_package = json
+    
+errh:
+    If Err.Number <> 0 Then
+        status = False
+        MsgBox (Err.Description)
+        Set scenario_package = Nothing
+    Else
+        status = True
+    End If
+    
+End Function
+
+Sub pg_main_workset(rep As String)
+
+    Dim req As New WinHttp.WinHttpRequest
+    Dim wapi As New Windows_API
+    Dim wr As String
+    Dim json As Object
+    Dim i As Long
+    Dim j As Long
+    Dim doc As String
+    Dim res() As Variant
+    Dim str() As String
+    
+    doc = "{""quota_rep"":""" & rep & """}"
+         
+    With req
+        .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
+        .Open "GET", handler.server & "/get_pool", True
+        .SetRequestHeader "Content-Type", "application/json"
+        .Send doc
+        .WaitForResponse
+        wr = .ResponseText
+    End With
+
+    If Mid(wr, 1, 1) <> "{" Then
+        MsgBox (wr)
+        Exit Sub
+    End If
+    Set json = JsonConverter.ParseJson(wr)
+    ReDim res(json("x").Count, 33)
+    
+    For i = 1 To UBound(res, 1)
+        res(i, 0) = json("x")(i)("bill_cust_descr")
+        res(i, 1) = json("x")(i)("billto_group")
+        res(i, 2) = json("x")(i)("ship_cust_descr")
+        res(i, 3) = json("x")(i)("shipto_group")
+        res(i, 4) = json("x")(i)("quota_rep_descr")
+        res(i, 5) = json("x")(i)("director")
+        res(i, 6) = json("x")(i)("segm")
+        res(i, 7) = json("x")(i)("substance")
+        res(i, 8) = json("x")(i)("chan")
+        res(i, 9) = json("x")(i)("chansub")
+        res(i, 10) = json("x")(i)("part_descr")
+        res(i, 11) = json("x")(i)("part_group")
+        res(i, 12) = json("x")(i)("branding")
+        res(i, 13) = json("x")(i)("majg_descr")
+        res(i, 14) = json("x")(i)("ming_descr")
+        res(i, 15) = json("x")(i)("majs_descr")
+        res(i, 16) = json("x")(i)("mins_descr")
+        res(i, 17) = json("x")(i)("order_season")
+        res(i, 18) = json("x")(i)("order_month")
+        res(i, 19) = json("x")(i)("ship_season")
+        res(i, 20) = json("x")(i)("ship_month")
+        res(i, 21) = json("x")(i)("request_season")
+        res(i, 22) = json("x")(i)("request_month")
+        res(i, 23) = json("x")(i)("promo")
+        res(i, 24) = json("x")(i)("value_loc")
+        res(i, 25) = json("x")(i)("value_usd")
+        res(i, 26) = json("x")(i)("cost_loc")
+        res(i, 27) = json("x")(i)("cost_usd")
+        res(i, 28) = json("x")(i)("units")
+        res(i, 29) = json("x")(i)("version")
+        res(i, 30) = json("x")(i)("iter")
+        res(i, 31) = json("x")(i)("logid")
+        res(i, 32) = json("x")(i)("tag")
+        res(i, 33) = json("x")(i)("comment")
+    Next i
+    
+    res(0, 0) = "bill_cust_descr"
+    res(0, 1) = "billto_group"
+    res(0, 2) = "ship_cust_descr"
+    res(0, 3) = "shipto_group"
+    res(0, 4) = "quota_rep_descr"
+    res(0, 5) = "director"
+    res(0, 6) = "segm"
+    res(0, 7) = "substance"
+    res(0, 8) = "chan"
+    res(0, 9) = "chansub"
+    res(0, 10) = "part_descr"
+    res(0, 11) = "part_group"
+    res(0, 12) = "branding"
+    res(0, 13) = "majg_descr"
+    res(0, 14) = "ming_descr"
+    res(0, 15) = "majs_descr"
+    res(0, 16) = "mins_descr"
+    res(0, 17) = "order_season"
+    res(0, 18) = "order_month"
+    res(0, 19) = "ship_season"
+    res(0, 20) = "ship_month"
+    res(0, 21) = "request_season"
+    res(0, 22) = "request_month"
+    res(0, 23) = "promo"
+    res(0, 24) = "value_loc"
+    res(0, 25) = "value_usd"
+    res(0, 26) = "cost_loc"
+    res(0, 27) = "cost_usd"
+    res(0, 28) = "units"
+    res(0, 29) = "version"
+    res(0, 30) = "iter"
+    res(0, 31) = "logid"
+    res(0, 32) = "tag"
+    res(0, 33) = "comment"
+    
+    Set json = Nothing
+
+    ReDim str(UBound(res, 1), UBound(res, 2))
+    
+    Worksheets("data").Cells.ClearContents
+    Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True)
+    
+
+End Sub
+
+Sub pull_rep()
+
+    openf.Show
+
+End Sub
+
+
+
+Function request_adjust(doc As String, ByRef fail As Boolean) As Object
+
+    Dim req As New WinHttp.WinHttpRequest
+    Dim json As Object
+    Dim wr As String
+    Dim i As Long
+    Dim j As Long
+    Dim str() As String
+    
+    If doc = "" Then
+        fail = True
+        Exit Function
+    End If
+    
+    'update timestamp
+    Set json = JsonConverter.ParseJson(doc)
+    'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss")
+    'doc = JsonConverter.ConvertToJson(doc)
+    
+    server = Sheets("config").Cells(1, 2)
+    
+    With req
+        .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
+        .Open "POST", server & "/" & json("type"), True
+        .SetRequestHeader "Content-Type", "application/json"
+        .Send doc
+        .WaitForResponse
+        wr = .ResponseText
+    End With
+    
+    If Mid(wr, 2, 5) = "error" Then
+        MsgBox (wr)
+        fail = True
+        Exit Function
+    End If
+    
+    If Mid(wr, 1, 6) = "<body>" Then
+        MsgBox (wr)
+        fail = True
+        Exit Function
+    End If
+    
+    If Mid(wr, 1, 6) = "<!DOCT" Then
+        MsgBox (wr)
+        fail = True
+        Exit Function
+    End If
+    
+    If Mid(wr, 1, 6) = "null" Then
+        MsgBox ("API route not implemented")
+        fail = True
+        Exit Function
+    End If
+
+    Set json = JsonConverter.ParseJson(wr)
+    
+    If IsNull(json("x")) Then
+        MsgBox ("no adjustment was made")
+        fail = False
+        Exit Function
+    End If
+    
+    ReDim res(json("x").Count - 1, 33)
+    
+    For i = 0 To UBound(res, 1)
+        res(i, 0) = json("x")(i + 1)("bill_cust_descr")
+        res(i, 1) = json("x")(i + 1)("billto_group")
+        res(i, 2) = json("x")(i + 1)("ship_cust_descr")
+        res(i, 3) = json("x")(i + 1)("shipto_group")
+        res(i, 4) = json("x")(i + 1)("quota_rep_descr")
+        res(i, 5) = json("x")(i + 1)("director")
+        res(i, 6) = json("x")(i + 1)("segm")
+        res(i, 7) = json("x")(i + 1)("substance")
+        res(i, 8) = json("x")(i + 1)("chan")
+        res(i, 9) = json("x")(i + 1)("chansub")
+        res(i, 10) = json("x")(i + 1)("part_descr")
+        res(i, 11) = json("x")(i + 1)("part_group")
+        res(i, 12) = json("x")(i + 1)("branding")
+        res(i, 13) = json("x")(i + 1)("majg_descr")
+        res(i, 14) = json("x")(i + 1)("ming_descr")
+        res(i, 15) = json("x")(i + 1)("majs_descr")
+        res(i, 16) = json("x")(i + 1)("mins_descr")
+        res(i, 17) = json("x")(i + 1)("order_season")
+        res(i, 18) = json("x")(i + 1)("order_month")
+        res(i, 19) = json("x")(i + 1)("ship_season")
+        res(i, 20) = json("x")(i + 1)("ship_month")
+        res(i, 21) = json("x")(i + 1)("request_season")
+        res(i, 22) = json("x")(i + 1)("request_month")
+        res(i, 23) = json("x")(i + 1)("promo")
+        res(i, 24) = json("x")(i + 1)("value_loc")
+        res(i, 25) = json("x")(i + 1)("value_usd")
+        res(i, 26) = json("x")(i + 1)("cost_loc")
+        res(i, 27) = json("x")(i + 1)("cost_usd")
+        res(i, 28) = json("x")(i + 1)("units")
+        res(i, 29) = json("x")(i + 1)("version")
+        res(i, 30) = json("x")(i + 1)("iter")
+        res(i, 31) = json("x")(i + 1)("logid")
+        res(i, 32) = json("x")(i + 1)("tag")
+        res(i, 33) = json("x")(i + 1)("comment")
+    Next i
+    
+    Set json = Nothing
+
+    ReDim str(UBound(res, 1), UBound(res, 2))
+    
+'    For i = 0 To UBound(res, 1)
+'        For j = 0 To UBound(res, 2)
+'            If IsNull(res(i, j)) Then
+'                str(i, j) = ""
+'            Else
+'                str(i, j) = res(i, j)
+'            End If
+'        Next j
+'    Next i
+    
+    i = 1
+    Do Until Sheets("data").Cells(i, 1) = ""
+        i = i + 1
+    Loop
+    
+    Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True)
+    
+    
+    'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
+    
+    Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
+    
+End Function
+
+Sub load_config()
+
+    Dim i As Integer
+    Dim j As Integer
+    '----server to use---------------------------------------------------------
+    handler.server = Sheets("config").Cells(1, 2)
+    '---basis-----------------------------------------------------------------
+    ReDim handler.basis(100)
+    i = 2
+    j = 0
+    Do While Sheets("config").Cells(2, i) <> ""
+        handler.basis(j) = Sheets("config").Cells(2, i)
+        j = j + 1
+        i = i + 1
+    Loop
+    ReDim Preserve handler.basis(j - 1)
+    '---baseline-----------------------------------------------------------------
+    ReDim handler.baseline(100)
+    i = 2
+    j = 0
+    Do While Sheets("config").Cells(3, i) <> ""
+        handler.baseline(j) = Sheets("config").Cells(3, i)
+        j = j + 1
+        i = i + 1
+    Loop
+    ReDim Preserve handler.baseline(j - 1)
+    '---adjustments-----------------------------------------------------------------
+    ReDim handler.adjust(100)
+    i = 2
+    j = 0
+    Do While Sheets("config").Cells(4, i) <> ""
+        handler.adjust(j) = Sheets("config").Cells(4, i)
+        j = j + 1
+        i = i + 1
+    Loop
+    ReDim Preserve handler.adjust(j - 1)
+    '---plan version--------------------------------------------------------------
+    handler.plan = Sheets("config").Cells(9, 2)
+    
+End Sub
+
+Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
+
+    Dim j As Object
+    Dim i As Integer
+    Dim r As Long
+    Dim sh As Worksheet
+    Set sh = Sheets("_month")
+    
+    Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
+    sh.Cells(1, 16) = JsonConverter.ConvertToJson(j)
+    
+    For i = 0 To 12
+        '------------volume-------------------
+        sh.Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
+        sh.Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
+        sh.Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
+        sh.Cells(i + 1, 4) = 0
+        sh.Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
+        
+        '------------value----------------------
+        sh.Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
+        sh.Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
+        sh.Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
+        sh.Cells(i + 1, 14) = 0
+        sh.Cells(i + 1, 15) = co_num(pkg(i, 8), 0)
+        
+        '-------------price----------------------
+        If i > 0 Then
+            '--prior--
+            If co_num(pkg(i, 1), 0) = 0 Then
+                sh.Cells(i + 1, 6) = 0
+            Else
+                sh.Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1)
+            End If
+            
+            '--base--
+            If co_num(pkg(i, 2), 0) = 0 Then
+                'if there is no monthly base volume,
+                'then use the prior price, if there was no prior price,
+                'then inherit the average price for the year before current adjustments
+                If sh.Cells(i, 7) <> 0 Then
+                    sh.Cells(i + 1, 7) = sh.Cells(i, 7)
+                Else
+                    If pkg(13, 1) + pkg(13, 2) = 0 Then
+                        sh.Cells(i + 1, 7) = 0
+                    Else
+                        sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
+                    End If
+                End If
+            Else
+                sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
+            End If
+            
+            '--adjust--
+            If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then
+                sh.Cells(i + 1, 8) = 0
+            Else
+                sh.Cells(i + 1, 8) = (Round(pkg(i, 7), 10) + Round(pkg(i, 6), 10)) / (Round(pkg(i, 3), 10) + Round(pkg(i, 2), 10)) - (Round(pkg(i, 6), 10) / Round(pkg(i, 2), 10))
+            End If
+            
+            '--current adjust--
+            sh.Cells(i + 1, 9) = 0
+            
+            '--forecast--
+            If co_num(pkg(i, 4), 0) = 0 Then
+                'if there is no monthly base volume,
+                'then use the prior price, if there was no prior price,
+                'then inherit the average price for the year before current adjustments
+                If sh.Cells(i, 10) <> 0 Then
+                    sh.Cells(i + 1, 10) = sh.Cells(i, 10)
+                Else
+                    If pkg(13, 1) + pkg(13, 2) = 0 Then
+                        sh.Cells(i + 1, 10) = 0
+                    Else
+                        sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
+                    End If
+                End If
+            Else
+                sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
+            End If
+            
+        End If
+        
+    Next i
+    
+    'scenario
+    Sheets("_month").Range("R1:S1000").ClearContents
+    For i = 0 To UBound(handler.sc, 1)
+        sh.Cells(i + 1, 18) = handler.sc(i, 0)
+        sh.Cells(i + 1, 19) = handler.sc(i, 1)
+    Next i
+    
+    'basket
+    sh.Range("U1:AC100000").ClearContents
+    Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
+    Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
+    Sheets("config").Cells(5, 2) = 0
+    Sheets("config").Cells(6, 2) = 0
+    Sheets("config").Cells(7, 2) = 0
+    
+    months.load_sheet
+    
+    
+End Sub
+
+Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
+
+    If one = "" Or IsNull(one) Then
+        co_num = two
+    Else
+        co_num = one
+    End If
+
+End Function
+
+
+Function list_changes(doc As String, ByRef fail As Boolean) As Variant()
+
+    Dim req As New WinHttp.WinHttpRequest
+    Dim json As Object
+    Dim wr As String
+    Dim i As Integer
+    Dim j As Integer
+    Dim res() As Variant
+    
+    If doc = "" Then
+        fail = True
+        Exit Function
+    End If
+    
+    server = Sheets("config").Cells(1, 2)
+    
+    With req
+        .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
+        .Open "GET", server & "/list_changes", True
+        .SetRequestHeader "Content-Type", "application/json"
+        .Send doc
+        .WaitForResponse
+        wr = .ResponseText
+    End With
+    
+    Set json = JsonConverter.ParseJson(wr)
+    
+    If IsNull(json("x")) Then
+        MsgBox ("no history")
+        fail = True
+        Exit Function
+    End If
+    
+    ReDim res(json("x").Count - 1, 7)
+    
+    For i = 0 To UBound(res, 1)
+        res(i, 0) = json("x")(i + 1)("user")
+        res(i, 1) = json("x")(i + 1)("quota_rep_descr")
+        res(i, 2) = json("x")(i + 1)("stamp")
+        res(i, 3) = json("x")(i + 1)("tag")
+        res(i, 4) = json("x")(i + 1)("comment")
+        res(i, 5) = json("x")(i + 1)("sales")
+        res(i, 6) = json("x")(i + 1)("id")
+        res(i, 7) = json("x")(i + 1)("doc")
+    Next i
+    
+    list_changes = res
+
+End Function
+
+Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant()
+
+    Dim req As New WinHttp.WinHttpRequest
+    Dim json As Object
+    Dim wr As String
+    Dim i As Integer
+    Dim j As Integer
+    Dim res() As Variant
+    Dim doc As String
+    Dim ds As Worksheet
+    
+    doc = "{""logid"":" & logid & "}"
+    
+    server = handler.server
+        
+    With req
+        .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
+        .Open "GET", server & "/undo_change", True
+        .SetRequestHeader "Content-Type", "application/json"
+        .Send doc
+        .WaitForResponse
+        wr = .ResponseText
+    End With
+    
+    Set json = JsonConverter.ParseJson(wr)
+    logid = json("x")(1)("id")
+    
+    '---------loop through and get a list of each row that needs deleted?-----
+    
+    Set ds = Sheets("data")
+    
+    j = 0
+    For i = 1 To 100
+        If ds.Cells(1, i) = "logid" Then
+            j = i
+            Exit For
+        End If
+    Next i
+    
+    If j = 0 Then
+        MsgBox ("current data set is not tracking changes, cannot isolate change locally")
+        fail = True
+        Exit Function
+    End If
+    
+    i = 2
+    While ds.Cells(i, 1) <> ""
+        If ds.Cells(i, j) = logid Then
+            ds.Rows(i).Delete
+        Else
+            i = i + 1
+        End If
+    Wend
+    
+    
+
+End Function
+
+
+Sub history()
+
+    changes.Show
+
+End Sub
+
+Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant()
+
+    Dim req As New WinHttp.WinHttpRequest
+    Dim json As Object
+    Dim wr As String
+    Dim i As Integer
+    Dim j As Integer
+    Dim res() As Variant
+    
+    If doc = "" Then
+        fail = True
+        Exit Function
+    End If
+    
+    server = Sheets("config").Cells(1, 2)
+    
+    With req
+        .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
+        .Open "GET", server & "/swap_fit", True
+        .SetRequestHeader "Content-Type", "application/json"
+        .Send doc
+        .WaitForResponse
+        wr = .ResponseText
+    End With
+    
+    Set json = JsonConverter.ParseJson(wr)
+    
+    If IsNull(json("x")) Then
+        MsgBox ("no history")
+        fail = True
+        Exit Function
+    End If
+    
+    ReDim res(json("x").Count - 1, 3)
+    
+    For i = 0 To UBound(res, 1)
+        res(i, 0) = json("x")(i + 1)("part")
+        res(i, 1) = json("x")(i + 1)("value_usd")
+        res(i, 2) = json("x")(i + 1)("swap")
+        res(i, 3) = json("x")(i + 1)("fit")
+    Next i
+    
+    get_swap_fit = res
+
+End Function

VBA/openf.frm

@@ -0,0 +1,51 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf 
+   Caption         =   "Open a Forecast"
+   ClientHeight    =   2025
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   3825
+   OleObjectBlob   =   "openf.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "openf"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub cbCancel_Click()
+    
+    openf.Hide
+    
+End Sub
+
+Private Sub cbOK_Click()
+
+    Application.StatusBar = "Retrieving data for " & cbDSM.value & "....."
+
+    openf.Caption = "retrieving data......"
+    Call handler.pg_main_workset(cbDSM.value)
+    Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
+    Application.StatusBar = False
+    openf.Hide
+
+End Sub
+
+Private Sub UserForm_Activate()
+
+    'handler.server = "http://192.168.1.69:3000"
+    handler.server = Sheets("config").Cells(1, 2)
+
+    Dim x As New TheBigOne
+    Dim d() As String
+    
+    openf.Caption = "Select a DSM"
+    d = x.SHTp_Get("reps", 1, 1, True)
+    
+    For i = 1 To UBound(d, 2)
+        Call cbDSM.AddItem(d(0, i))
+    Next i
+
+
+End Sub
+

VBA/part.frm

@@ -0,0 +1,48 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part 
+   Caption         =   "Part Picker"
+   ClientHeight    =   1080
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   8100
+   OleObjectBlob   =   "part.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "part"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Public part As String
+Public bill As String
+Public ship As String
+Public useval As Boolean
+Option Explicit
+
+
+Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
+
+    Select Case KeyCode
+        Case 13
+            useval = True
+            Me.Hide
+        Case 27
+            useval = False
+            Me.Hide
+    End Select
+
+End Sub
+
+
+
+Private Sub UserForm_Activate()
+    
+    useval = False
+    
+    cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
+    
+
+End Sub
+
+

VBA/pivot.cls

@@ -0,0 +1,122 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "pivot"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
+Private Sub Worksheet_Activate()
+
+End Sub
+
+Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
+
+    If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then
+        Exit Sub
+    End If
+
+    On Error GoTo nopiv
+
+    If Target.Cells.PivotTable Is Nothing Then
+        Exit Sub
+    End If
+
+    Cancel = True
+
+    Dim i As Long
+    Dim j As Long
+    Dim k As Long
+    
+    Dim ri As PivotItemList
+    Dim ci As PivotItemList
+    Dim df As Object
+    Dim rd As Object
+    Dim cd As Object
+    Dim dd As Object
+    
+    Dim pt As PivotTable
+    Dim pf As PivotField
+    Dim pi As PivotItem
+    Dim wapi As New Windows_API
+    
+    Set ri = Target.Cells.PivotCell.RowItems
+    Set ci = Target.Cells.PivotCell.ColumnItems
+    Set df = Target.Cells.PivotCell.DataField
+
+    Set rd = Target.Cells.PivotTable.RowFields
+    Set cd = Target.Cells.PivotTable.ColumnFields
+    
+    ReDim handler.sc(ri.Count, 1)
+    Set pt = Target.Cells.PivotCell.PivotTable
+    
+    handler.sql = ""
+    handler.jsql = ""
+
+    For i = 1 To ri.Count
+        If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
+        If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
+        handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
+        jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
+        handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
+        handler.sc(i - 1, 1) = ri(i).Name
+    Next i
+    
+    scenario = "{" & handler.jsql & "}"
+    
+    Call handler.load_config
+    Call handler.load_fpvt
+    
+nopiv:
+
+End Sub
+
+Function piv_pos(list As Object, target_pos As Long) As Long
+
+    Dim i As Long
+    
+    For i = 1 To list.Count
+        If list(i).Position = target_pos Then
+            piv_pos = i
+            Exit Function
+        End If
+    Next i
+    'should not get to this point
+
+End Function
+
+Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
+
+    Dim i As Integer
+    
+    For i = 1 To pt.PivotFields.Count
+        If pt.PivotFields(i).Name = field_name Then
+            piv_fld_index = i
+            Exit Function
+        End If
+    Next i
+
+End Function
+
+Function escape_json(ByVal text As String) As String
+
+    text = Replace(text, "'", "''")
+    text = Replace(text, """", "\""")
+    If text = "(blank)" Then text = ""
+    escape_json = text
+
+End Function
+
+Function escape_sql(ByVal text As String) As String
+
+    text = Replace(text, "'", "''")
+    text = Replace(text, """", """""")
+    If text = "(blank)" Then text = ""
+    escape_sql = text
+
+End Function
+
+

VBA/pivot1.cls

@@ -0,0 +1,122 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "pivot1"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
+Private Sub Worksheet_Activate()
+
+End Sub
+
+Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
+
+    If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
+        Exit Sub
+    End If
+
+    On Error GoTo nopiv
+
+    If Target.Cells.PivotTable Is Nothing Then
+        Exit Sub
+    End If
+
+    Cancel = True
+
+    Dim i As Long
+    Dim j As Long
+    Dim k As Long
+    
+    Dim ri As PivotItemList
+    Dim ci As PivotItemList
+    Dim df As Object
+    Dim rd As Object
+    Dim cd As Object
+    Dim dd As Object
+    
+    Dim pt As PivotTable
+    Dim pf As PivotField
+    Dim pi As PivotItem
+    Dim wapi As New Windows_API
+    
+    Set ri = Target.Cells.PivotCell.RowItems
+    Set ci = Target.Cells.PivotCell.ColumnItems
+    Set df = Target.Cells.PivotCell.DataField
+
+    Set rd = Target.Cells.PivotTable.RowFields
+    Set cd = Target.Cells.PivotTable.ColumnFields
+    
+    ReDim handler.sc(ri.Count, 1)
+    Set pt = Target.Cells.PivotCell.PivotTable
+    
+    handler.sql = ""
+    handler.jsql = ""
+
+    For i = 1 To ri.Count
+        If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
+        If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
+        handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
+        jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
+        handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
+        handler.sc(i - 1, 1) = ri(i).Name
+    Next i
+    
+    scenario = "{" & handler.jsql & "}"
+    
+    Call handler.load_config
+    Call handler.load_fpvt
+    
+nopiv:
+
+End Sub
+
+Function piv_pos(list As Object, target_pos As Long) As Long
+
+    Dim i As Long
+    
+    For i = 1 To list.Count
+        If list(i).Position = target_pos Then
+            piv_pos = i
+            Exit Function
+        End If
+    Next i
+    'should not get to this point
+
+End Function
+
+Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
+
+    Dim i As Integer
+    
+    For i = 1 To pt.PivotFields.Count
+        If pt.PivotFields(i).Name = field_name Then
+            piv_fld_index = i
+            Exit Function
+        End If
+    Next i
+
+End Function
+
+Function escape_json(ByVal text As String) As String
+
+    text = Replace(text, "'", "''")
+    text = Replace(text, """", "\""")
+    If text = "(blank)" Then text = ""
+    escape_json = text
+
+End Function
+
+Function escape_sql(ByVal text As String) As String
+
+    text = Replace(text, "'", "''")
+    text = Replace(text, """", """""")
+    If text = "(blank)" Then text = ""
+    escape_sql = text
+
+End Function
+
+

build/build_forecast.sql

@@ -1,33 +1,18 @@
 -- Connection: usmidsap01.ubm
 --\timing
+
+/*----------------------------------------------------------------------------------------
+1. copy existing actuals for the current season (which is incomplete)
+    * for example 6/1/22 -> 3/7/23
+2. fill out a full year of history by going back 2 years to get 3/8/22 -> 5/31/22
+3. stack the results of 1 & 2 and increment all rows by 1 year
+*/----------------------------------------------------------------------------------------
+
 TRUNCATE TABLE rlarp.osmf;
 
 INSERT INTO rlarp.osmf
 WITH
-gld AS (
-    SELECT
-        N1COMP COMP
-        ,N1CCYY FSYR
-        ,KPMAXP PERDS
-        ,N1FSPP PERD
-        ,to_char(N1FSYP,'FM0000') FSPR
-        ,N1SD01 SDAT
-        ,N1ED01 EDAT
-        ,to_char(N1ED01,'yymm') CAPR
-        ,N1ED01 - N1SD01 +1 NDAYS
-        ,CASE WHEN EXTRACT(MONTH FROM N1ED01) >= 6 THEN EXTRACT(YEAR FROM N1ED01) + 1 ELSE EXTRACT(YEAR FROM N1ED01) END SSYR
-        ,to_char(CASE WHEN EXTRACT(MONTH FROM N1ED01) >= 6 THEN EXTRACT(MONTH FROM N1ED01) -5  ELSE EXTRACT(MONTH FROM N1ED01) +7 END,'00') SSPR
-    FROM
-        LGDAT.GLDATREF
-        INNER JOIN LGDAT.GLDATE ON
-            KPCOMP = N1COMP AND
-            KPCCYY = N1CCYY
-    WHERE
-        N1COMP = 93
-        --AND DIGITS(N1FSYP) = '1901'
-)
---SELECT * FROM gld
-,baseline AS (
+baseline AS (
     SELECT
         -----------documents-------------
         null::int "ddord#"
@@ -137,15 +122,15 @@ gld AS (
         -----when null, greatest/least is just going to act like coalesce
         ,greatest(least(o.sdate,gld.edat),gld.sdat) sdate
         ,ss.ssyr sseas
-        ,'15mo' "version"
+        ,'b23' "version"
         ,'actuals' iter
     FROM
         rlarp.osm o
         --snap the ship dates of the historic fiscal period
-        LEFT OUTER JOIN gld ON
+        LEFT OUTER JOIN rlarp.gld ON
             gld.fspr = o.fspr
         --get the shipping season for open orders based on the snapped date
-        LEFT OUTER JOIN gld ss ON
+        LEFT OUTER JOIN rlarp.gld ss ON
             greatest(least(o.sdate,gld.edat),gld.sdat) BETWEEN ss.sdat AND ss.edat
     WHERE
         (
@@ -295,19 +280,23 @@ gld AS (
         -----when null, greatest/least is just going to act like coalesce
         ,greatest(least(o.sdate,gld.edat),gld.sdat)  + interval '1 year' sdate
         ,ss.ssyr  sseas
-        ,'actuals' "version"
+        ,'b23' "version"
         ,'actuals_plug' iter
     FROM
         rlarp.osm o
-        LEFT OUTER JOIN gld ON
+        LEFT OUTER JOIN rlarp.gld ON
             gld.fspr = o.fspr
-        LEFT OUTER JOIN gld ss ON
+        LEFT OUTER JOIN rlarp.gld ss ON
             greatest(least(o.sdate,gld.edat),gld.sdat) + interval '1 year' BETWEEN ss.sdat AND ss.edat
     WHERE
         o.odate BETWEEN '2022-03-01' AND '2022-05-31'
         AND fs_line = '41010'
         AND calc_status <> 'CANCELED'
-        ------exclude actuals for now and use forecast to get the plug for the rest of the year
+        AND NOT (calc_status = 'CLOSED' AND flag = 'REMAINDER')
+        --OR (
+        --    (o.fspr BETWEEN '2209' AND '2212' OR o.fspr = '0000') 
+        --    AND o.sdate BETWEEN '2022-03-01' AND '2022-05-31'
+        --)
         AND version = 'ACTUALS'
     GROUP BY
         o.fspr
@@ -443,13 +432,13 @@ gld AS (
         -----when null, greatest/least is just going to act like coalesce
         ,greatest(least(o.sdate,gld.edat),gld.sdat) sdate
         ,ss.ssyr  sseas
-        ,'actuals' "version"
+        ,'b23' "version"
         ,'forecast_plug' iter
     FROM
         rlarp.osmp o
-        LEFT OUTER JOIN gld ON
+        LEFT OUTER JOIN rlarp.gld ON
             gld.fspr = o.fspr
-        LEFT OUTER JOIN gld ss ON
+        LEFT OUTER JOIN rlarp.gld ss ON
             greatest(least(o.sdate,gld.edat),gld.sdat)  BETWEEN ss.sdat AND ss.edat
     WHERE
         false
@@ -479,6 +468,7 @@ gld AS (
         ,greatest(least(o.sdate,gld.edat),gld.sdat)
         ,ss.ssyr
 )
+----------increment the baseline selection---------------------
 ,incr AS (
 SELECT
     o."ddord#"
@@ -589,8 +579,8 @@ SELECT
     ,'copy' iter
 FROM
     baseline o
-    LEFT OUTER JOIN gld ON
-        o.sdate + interval '1 year' BETWEEN gld.sdat and gld.edat
+    LEFT OUTER JOIN rlarp.gld ON
+        (o.sdate + interval '1 year') BETWEEN gld.sdat and gld.edat
 WHERE
     o.odate + interval '1 year' >= '2023-06-01'
 )

build/convert_pool_all.sql

@@ -3,11 +3,12 @@ LANGUAGE plpgsql AS
 $func$
 BEGIN
 
-DELETE FROM rlarp.osmfs_dev;
+DELETE FROM rlarp.osmfs;
 
 INSERT INTO
-    rlarp.osmfs_dev
+    rlarp.osmfs
 SELECT
+    ------------document ids---------------------
     null::int4,
     null::int4,
     null::int4,
@@ -16,14 +17,17 @@ SELECT
     null::int4,
     null::int4,
     null::int4,
+    ------------document dates-------------------
     order_date,
     request_date,
     null::date,
     null::date,
     ship_date,
+    ------------document flags-------------------
     null::text,
     null::text,
     fspr,
+    ------------document quantities--------------
     null::numeric,
     null::numeric,
     null::numeric,
@@ -31,6 +35,7 @@ SELECT
     null::numeric,
     null::numeric,
     null::jsonb,
+    ------------document attributes--------------
     null::text,
     plnt,
     promo,
@@ -38,6 +43,7 @@ SELECT
     terms,
     null::text,
     null::text,
+    ------------customer info---------------------
     null::text,
     rtrim(substring(bill_cust_descr,1,8)),
     null::text,
@@ -61,6 +67,7 @@ SELECT
     null::text,
     null::text,
     null::text,
+    ------------product info----------------------
     part,
     null::text,
     null::text,
@@ -84,8 +91,10 @@ SELECT
     null::text,
     null::text,
     null::text,
+    null::text,
     null::numeric,
     null::numeric,
+    ------------fiscal info-----------------------
     null::text,
     fs_line,
     r_currency,
@@ -101,12 +110,15 @@ SELECT
     cost_loc,
     null::numeric,
     null::numeric,
+    ------------status info-----------------------
     calc_status,
     flag,
     order_date,
     order_season,
     request_date,
     request_season,
+    null::date promise_date,
+    null::int  promise_season,
     ship_date,
     ship_season,
     version,
@@ -115,37 +127,38 @@ SELECT
 FROM
     rlarp.osm_pool
 WHERE
-    version <> 'actuals'
+    version <> 'actuals';
 
 -------need to set item master values before other things-----------
 UPDATE
-    RLARP.OSMFS_DEV O
+    RLARP.osmfs O
 SET
-    STYC = M.STLC
-    ,COLC = M.COLC
-    ,COLGRP = M.COLGRP
-    ,COLTIER = M.COLTIER
-    ,COLSTAT = M.COLSTAT
-    ,SIZC = M.SIZC
-    ,PCKG = M.PACKAGE
-    ,KIT = M.KIT
-    ,BRND = M.BRANDING
-    ,MAJG = M.MAJG
-    ,MING = M.MING
-    ,MAJS = M.MAJS
-    ,MINS = M.MINS
-    ,GLDC = M.GLCD
-    ,GLEC = M.GLEC
-    ,HARM = M.HARM
-    ,CLSS = M.CLSS
-    ,BRAND = M.BRAND
-    ,ASSC = M.ASSC
-    ,LBS = CASE M.NWUN WHEN 'KG' THEN 2.2046 ELSE 1 END*M.NWHT
-    ,UNTI = M.UNTI
+     stlc = m.stlc
+    ,colc = m.colc
+    ,colgrp = m.colgrp
+    ,coltier = m.coltier
+    ,colstat = m.colstat
+    ,sizc = m.sizc
+    ,uomp = m.uomp
+    ,suffix = m.suffix
+    ,accs_ps = m.accs_ps
+    ,brnd = m.branding
+    ,majg = m.majg
+    ,ming = m.ming
+    ,majs = m.majs
+    ,mins = m.mins
+    ,gldc = m.glcd
+    ,glec = m.glec
+    ,harm = m.harm
+    ,clss = m.clss
+    ,brand = m.brand
+    ,assc = m.assc
+    ,lbs = CASE m.nwun WHEN 'kg' THEN 2.2046 ELSE 1 END*m.nwht
+    ,unti = m.unti
 FROM
-    RLARP.ITEMM M
+    "CMS.CUSLG".itemm m
 WHERE
-    M.ITEM = O.PART;
+    m.item = o.part;
 
 
 WITH
@@ -154,7 +167,7 @@ plist AS (
         part
         ,plnt
     FROM
-        rlarp.osmfS_dev
+        rlarp.osmfs
 )
 ,clist AS (
     SELECT
@@ -174,7 +187,7 @@ plist AS (
             AND ir.y0plnt = p.plnt
 )
 UPDATE
-    rlarp.osmfs_dev o
+    rlarp.osmfs o
 SET
     fb_cst_loc_cur = c.stdcost * o.fb_qty
 FROM
@@ -186,7 +199,7 @@ WHERE
 ----------------------------SET BILL-TO REP------------------------------------
 
 UPDATE
-    RLARP.OSMFS_DEV S
+    RLARP.osmfs S
 SET
     BILL_REP = C.BVSALM
     ,BILL_CLASS = C.BVCLAS
@@ -213,7 +226,7 @@ WHERE
 ----------------------------SET SHIP-TO REP------------------------------------
 
 UPDATE
-    RLARP.OSMFS_DEV S
+    RLARP.osmfs S
 SET
     SHIP_REP = C.BVSALM
     ,SHIP_CLASS = C.BVCLAS
@@ -226,18 +239,18 @@ FROM
 WHERE
     C.BVCUST = S.SHIP_CUST
     AND (
-        COALESCE(S.SHIP_REP,'') <> C.BVSALM 
-        OR COALESCE(S.SHIP_CLASS,'') <> C.BVCLAS 
-        OR COALESCE(S.SHIP_TERR,'') <> C.BVTERR
-        OR COALESCE(dest_CTRY,'') <> C.bvctry 
-        OR COALESCE(dest_prov,'') <> C.bvprcd
-        OR COALESCE(dest_post,'') <> C.bvpost 
+           COALESCE(s.ship_rep,'') <> c.bvsalm 
+        OR COALESCE(s.ship_class,'') <> c.bvclas 
+        OR COALESCE(s.ship_terr,'') <> c.bvterr
+        OR COALESCE(dest_ctry,'') <> c.bvctry 
+        OR COALESCE(dest_prov,'') <> c.bvprcd
+        OR COALESCE(dest_post,'') <> c.bvpost 
     );
 
 ----------------------------SET BILLTO GROUP------------------------------------
 
 UPDATE
-    RLARP.OSMFS_DEV O
+    RLARP.osmfs O
 SET
     ACCOUNT = CASE BVADR6 WHEN '' THEN BVNAME ELSE BVADR6 END
 FROM
@@ -251,7 +264,7 @@ WHERE
 ----------------------------SET SHIPTO GROUP------------------------------------
 
 UPDATE
-    RLARP.OSMFS_DEV O
+    RLARP.osmfs O
 SET
     SHIPGRP = CASE BVADR6 WHEN '' THEN BVNAME ELSE BVADR6 END
 FROM
@@ -265,7 +278,7 @@ WHERE
 
 
 UPDATE
-    rlarp.osmFS_dev
+    rlarp.osmfs
 SET
     CHAN =  CASE SUBSTRING(BILL_CLASS,2,3) 
                 --if the bill to class is ditsributor, then it's either warehouse or drop
@@ -321,7 +334,7 @@ WHERE
 
 
 UPDATE
-    RLARP.OSMFS_DEV S
+    RLARP.osmfs S
 SET
     DSM = CR.QUOTA_REP
 FROM
@@ -349,8 +362,8 @@ FROM
         END QUOTA_REP
 
     FROM 
-        RLARP.OSMFS_DEV S
-        LEFT OUTER JOIN LGDAT.CUST ON
+        RLARP.osmfs S
+        LEFT OUTER JOIN lgdat.cust ON
             BVCUST = BILL_CUST
         LEFT OUTER JOIN lgpgm.usrcust cu ON 
             cu.cucust = s.bill_cust
@@ -358,7 +371,7 @@ FROM
         COALESCE(GLEC,'') IS NOT NULL
     ) CR
 WHERE
-    CR.VERSION = S.VERSION
+        CR.VERSION = S.VERSION
     AND CR.GLEC = COALESCE(S.GLEC,'')
     AND CR.MING = COALESCE(S.MING,'')
     AND CR.BILL_CUST = S.BILL_CUST 
@@ -369,7 +382,7 @@ WHERE
 -------------------set fiscal period--------------------------------------
 
 UPDATE
-    rlarp.osmfs_dev f
+    rlarp.osmfs f
 SET
     fspr = gld.fspr
 FROM
@@ -430,7 +443,7 @@ WHERE
 
 --DELETE FROM rlarp.osmf_dev WHERE iter IN ('adj price','adj volume');
 
---INSERT INTO rlarp.osmf_dev SELECT * FROM rlarp.osmfs_dev;
+--INSERT INTO rlarp.osmf_dev SELECT * FROM rlarp.osmf;
 
 COMMIT;
 END

inquirey/osmf_months.sql

@@ -1,15 +1,21 @@
 SELECT
+    --o.glec
     to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon') order_month
-    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2021 AND iter = 'plan'),0) plan2021
-    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2022 AND iter = 'plan'),0) plan2022
-    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2021 AND iter = 'diff'),0) diff2021
-    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2022 AND iter = 'diff'),0) diff2022
-    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2021 AND iter = 'actuals'),0) act2021
-    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2022 AND iter = 'actuals'),0) act2022
+    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2023 AND iter = 'actuals'),0)         act2023
+    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2023 AND iter = 'actuals_plug'),0)    act2023_plug
+    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2023 AND version IN ('actuals','15mo')),0)    total_baseline
+    ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2024 AND version = 'b23'),0)          plan2024
 FROM
-    rlarp.osmfs_dev o
+    rlarp.osmf o
 WHERE
-    oseas IN (2021,2022)
+    oseas IN (2023,2024)
+    AND substring(glec,1,1) <= '2'
     --AND quota_rep_descr = 'COLIN MAXWELL'
 GROUP BY
-    to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon')
+    ROLLUP (
+        --o.glec,
+        to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon')
+        )
+ORDER BY
+    --o.glec,
+    order_month