forecast_api/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 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....."
    
    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 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)
    
    If IsNull(json("x")) Then
        MsgBox "No data found for " & rep & "."
        Exit Sub
    End If
    
    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))
    
    shData.Cells.ClearContents
    Call Utils.SHTp_DumpVar(res, shData.Name, 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 = shConfig.Range("server").value
    
    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 shData.Cells(i, 1) = ""
        i = i + 1
    Loop
    
    Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True)
    
    
    'Call Utils.SHTp_Dump(str, shData.Name, CLng(i), 1, False, False, 28, 29, 30, 31, 32)
    
    shOrders.PivotTables("ptOrders").PivotCache.Refresh
    
End Function

Sub load_config()

    Dim i As Integer
    '----server to use---------------------------------------------------------
    handler.server = shConfig.Range("server").value
    '---basis-----------------------------------------------------------------
    With shConfig.ListObjects("BASIS")
        For i = 1 To .DataBodyRange.Rows.Count
            ReDim Preserve handler.basis(i - 1)
            handler.basis(i - 1) = .DataBodyRange(i, 1)
        Next
    End With
    '---baseline-----------------------------------------------------------------
    With shConfig.ListObjects("BASELINE")
        For i = 1 To .DataBodyRange.Rows.Count
            ReDim Preserve handler.baseline(i - 1)
            handler.baseline(i - 1) = .DataBodyRange(i, 1)
        Next
    End With
    '---adjustments-----------------------------------------------------------------
    With shConfig.ListObjects("ADJUST")
        For i = 1 To .DataBodyRange.Rows.Count
            ReDim Preserve handler.adjust(i - 1)
            handler.adjust(i - 1) = .DataBodyRange(i, 1)
        Next
    End With
    '---plan version--------------------------------------------------------------
    handler.plan = shConfig.Range("budget").value
    
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
    
    With shMonthUpdate
    
        Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
        .Cells(1, 16) = JsonConverter.ConvertToJson(j)
        
        For i = 0 To 12
            '------------volume-------------------
            .Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
            .Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
            .Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
            .Cells(i + 1, 4) = 0
            .Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
            
            '------------value----------------------
            .Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
            .Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
            .Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
            .Cells(i + 1, 14) = 0
            .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
                    .Cells(i + 1, 6) = 0
                Else
                    .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 .Cells(i, 7) <> 0 Then
                        .Cells(i + 1, 7) = .Cells(i, 7)
                    Else
                        If pkg(13, 1) + pkg(13, 2) = 0 Then
                            .Cells(i + 1, 7) = 0
                        Else
                            .Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
                        End If
                    End If
                Else
                    .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
                    .Cells(i + 1, 8) = 0
                Else
                    .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--
                .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 .Cells(i, 10) <> 0 Then
                        .Cells(i + 1, 10) = .Cells(i, 10)
                    Else
                        If pkg(13, 1) + pkg(13, 2) = 0 Then
                            .Cells(i + 1, 10) = 0
                        Else
                            .Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
                        End If
                    End If
                Else
                    .Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
                End If
                
            End If
            
        Next i
        
        'scenario
        .Range("R1:S1000").ClearContents
        For i = 0 To UBound(handler.sc, 1)
            .Cells(i + 1, 18) = handler.sc(i, 0)
            .Cells(i + 1, 19) = handler.sc(i, 1)
        Next i
        
        'basket
        .Range("U1:AC100000").ClearContents
        Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True)
        Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True)
        shConfig.Range("rebuild").value = 0
        shConfig.Range("show_basket").value = 0
        shConfig.Range("new_part").value = 0
        
        shMonthView.load_sheet
    
    End With
        
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 = shConfig.Range("server").value
    
    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?-----
       
    j = 0
    For i = 1 To 100
        If shData.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
    With shData
        While .Cells(i, 1) <> ""
            If .Cells(i, j) = logid Then
                .Rows(i).Delete
            Else
                i = i + 1
            End If
        Wend
    End With

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 = shConfig.Range("server").value
    
    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