VBA/handler.bas

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 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.ListBox1.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

    Set json = JsonConverter.ParseJson(wr)
    ReDim res(json("x").Count, 32)
    
    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_descr")
        res(i, 6) = json("x")(i)("segm")
        res(i, 7) = json("x")(i)("mod_chan")
        res(i, 8) = json("x")(i)("mod_chansub")
        res(i, 9) = json("x")(i)("majg_descr")
        res(i, 10) = json("x")(i)("ming_descr")
        res(i, 11) = json("x")(i)("majs_descr")
        res(i, 12) = json("x")(i)("mins_descr")
        res(i, 13) = json("x")(i)("brand")
        res(i, 14) = json("x")(i)("part_family")
        res(i, 15) = json("x")(i)("part_group")
        res(i, 16) = json("x")(i)("branding")
        res(i, 17) = json("x")(i)("color")
        res(i, 18) = json("x")(i)("part_descr")
        res(i, 19) = json("x")(i)("order_season")
        res(i, 20) = json("x")(i)("order_month")
        res(i, 21) = json("x")(i)("ship_season")
        res(i, 22) = json("x")(i)("ship_month")
        res(i, 23) = json("x")(i)("request_season")
        res(i, 24) = json("x")(i)("request_month")
        res(i, 25) = json("x")(i)("promo")
        res(i, 26) = json("x")(i)("version")
        res(i, 27) = json("x")(i)("iter")
        res(i, 28) = json("x")(i)("value_loc")
        res(i, 29) = json("x")(i)("value_usd")
        res(i, 30) = json("x")(i)("cost_loc")
        res(i, 31) = json("x")(i)("cost_usd")
        res(i, 32) = json("x")(i)("units")
    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_descr"
    res(0, 6) = "segm"
    res(0, 7) = "mod_chan"
    res(0, 8) = "mod_chansub"
    res(0, 9) = "majg_descr"
    res(0, 10) = "ming_descr"
    res(0, 11) = "majs_descr"
    res(0, 12) = "mins_descr"
    res(0, 13) = "brand"
    res(0, 14) = "part_family"
    res(0, 15) = "part_group"
    res(0, 16) = "branding"
    res(0, 17) = "color"
    res(0, 18) = "part_descr"
    res(0, 19) = "order_season"
    res(0, 20) = "order_month"
    res(0, 21) = "ship_season"
    res(0, 22) = "ship_month"
    res(0, 23) = "request_season"
    res(0, 24) = "request_month"
    res(0, 25) = "promo"
    res(0, 26) = "version"
    res(0, 27) = "iter"
    res(0, 28) = "value_loc"
    res(0, 29) = "value_usd"
    res(0, 30) = "cost_loc"
    res(0, 31) = "cost_usd"
    res(0, 32) = "units"
    
    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

    Set json = JsonConverter.ParseJson(wr)
    
    If IsNull(json("x")) Then
        MsgBox ("no adjustment was made")
        fail = True
        Exit Function
    End If
    
    ReDim res(json("x").Count - 1, 32)
    
    For i = 1 To UBound(res, 1) + 1
        res(i - 1, 0) = json("x")(i)("bill_cust_descr")
        res(i - 1, 1) = json("x")(i)("billto_group")
        res(i - 1, 2) = json("x")(i)("ship_cust_descr")
        res(i - 1, 3) = json("x")(i)("shipto_group")
        res(i - 1, 4) = json("x")(i)("quota_rep_descr")
        res(i - 1, 5) = json("x")(i)("director_descr")
        res(i - 1, 6) = json("x")(i)("segm")
        res(i - 1, 7) = json("x")(i)("mod_chan")
        res(i - 1, 8) = json("x")(i)("mod_chansub")
        res(i - 1, 9) = json("x")(i)("majg_descr")
        res(i - 1, 10) = json("x")(i)("ming_descr")
        res(i - 1, 11) = json("x")(i)("majs_descr")
        res(i - 1, 12) = json("x")(i)("mins_descr")
        res(i - 1, 13) = json("x")(i)("brand")
        res(i - 1, 14) = json("x")(i)("part_family")
        res(i - 1, 15) = json("x")(i)("part_group")
        res(i - 1, 16) = json("x")(i)("branding")
        res(i - 1, 17) = json("x")(i)("color")
        res(i - 1, 18) = json("x")(i)("part_descr")
        res(i - 1, 19) = json("x")(i)("order_season")
        res(i - 1, 20) = json("x")(i)("order_month")
        res(i - 1, 21) = json("x")(i)("ship_season")
        res(i - 1, 22) = json("x")(i)("ship_month")
        res(i - 1, 23) = json("x")(i)("request_season")
        res(i - 1, 24) = json("x")(i)("request_month")
        res(i - 1, 25) = json("x")(i)("promo")
        res(i - 1, 26) = json("x")(i)("version")
        res(i - 1, 27) = json("x")(i)("iter")
        res(i - 1, 28) = json("x")(i)("value_loc")
        res(i - 1, 29) = json("x")(i)("value_usd")
        res(i - 1, 30) = json("x")(i)("cost_loc")
        res(i - 1, 31) = json("x")(i)("cost_usd")
        res(i - 1, 32) = json("x")(i)("units")
    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)
    
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) = (pkg(i, 7) + pkg(i, 6)) / (pkg(i, 3) + pkg(i, 2)) - (pkg(i, 6) / pkg(i, 2))
            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, 5)
    
    For i = 0 To UBound(res, 1)
        res(i, 0) = json("x")(i + 1)("user")
        res(i, 1) = json("x")(i + 1)("stamp")
        res(i, 2) = json("x")(i + 1)("comment")
        res(i, 3) = json("x")(i + 1)("sales")
        res(i, 4) = json("x")(i + 1)("def")
    Next i
    
    list_changes = res

End Function

Sub history()

    changes.Show

End Sub