forecast_api/VBA/handler.bas

637 lines
18 KiB
QBasic

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, 34)
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")
res(i, 34) = json("x")(i)("pounds")
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"
res(0, 34) = "pounds"
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, 34)
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")
res(i, 34) = json("x")(i + 1)("pounds")
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 = 1 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.LoadSheet
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