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) = "" Then MsgBox (wr) fail = True Exit Function End If If Mid(wr, 1, 6) = " 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