pt/forecast_api
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
eeb2fd8eba
forecast_api/VBA/handler.bas
PhilRunninger 3fa2cb07f5 Batch error messages and identify period to which they apply. 
This happens on the Monthly view, and it's possible to get multiple
error messages, even among other successful month adjustments. There was
no way of knowing which month was the offending one or if any had
succeeded when an error was shown.

This change collects all the error messages into one message with the
period so that it's more intuitive and less obtrusive.
2023-08-31 17:07:58 -04:00

656 lines
20 KiB
QBasic
Raw Blame History

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
Debug.Print "GET /scenario_package (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
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(catg As String, rep As String)
Dim req As New WinHttp.WinHttpRequest
Dim wr As String
Dim json As Object
Dim doc As String
Dim res() As Variant
doc = "{""scenario"":{""" & catg & """:""" & rep & """}}"
Application.StatusBar = "Querying for " & rep & "'s pool of data..."
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", handler.server & "/get_pool", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
Debug.Print "GET /get_pool (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
If Mid(wr, 1, 1) <> "{" Then
MsgBox (wr)
Exit Sub
End If
Application.StatusBar = "Parsing query results..."
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox "No data found for " & rep & "."
Exit Sub
End If
ReDim res(0, 34)
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"
shData.Cells.ClearContents
Call Utils.SHTp_DumpVar(res, shData.Name, 1, 1, False, True, True)
Dim batchSize As Integer
batchSize = 1000
Dim totalRows As Long
totalRows = json("x").Count
Dim jsonRow As Long
jsonRow = 1
Dim sheetRow As Long
sheetRow = 2
Dim arrayRow As Long
' While the JSON array still has rows,
' 1. move the 1st one to a VBA 2-D array, deleting it from the JSON array.
' 2. When 1000 have been copied, put the values onto the worksheet, and
' empty the VBA array.
' Splitting the JSON array into smaller batches when creating the VBA array
' means there is less memory needed for the operation.
Do While json("x").Count > 0
If jsonRow Mod batchSize = 1 Then
ReDim res(batchSize - 1, 34)
arrayRow = 0
End If
res(arrayRow, 0) = json("x")(1)("bill_cust_descr")
res(arrayRow, 1) = json("x")(1)("billto_group")
res(arrayRow, 2) = json("x")(1)("ship_cust_descr")
res(arrayRow, 3) = json("x")(1)("shipto_group")
res(arrayRow, 4) = json("x")(1)("quota_rep_descr")
res(arrayRow, 5) = json("x")(1)("director")
res(arrayRow, 6) = json("x")(1)("segm")
res(arrayRow, 7) = json("x")(1)("substance")
res(arrayRow, 8) = json("x")(1)("chan")
res(arrayRow, 9) = json("x")(1)("chansub")
res(arrayRow, 10) = json("x")(1)("part_descr")
res(arrayRow, 11) = json("x")(1)("part_group")
res(arrayRow, 12) = json("x")(1)("branding")
res(arrayRow, 13) = json("x")(1)("majg_descr")
res(arrayRow, 14) = json("x")(1)("ming_descr")
res(arrayRow, 15) = json("x")(1)("majs_descr")
res(arrayRow, 16) = json("x")(1)("mins_descr")
res(arrayRow, 17) = json("x")(1)("order_season")
res(arrayRow, 18) = json("x")(1)("order_month")
res(arrayRow, 19) = json("x")(1)("ship_season")
res(arrayRow, 20) = json("x")(1)("ship_month")
res(arrayRow, 21) = json("x")(1)("request_season")
res(arrayRow, 22) = json("x")(1)("request_month")
res(arrayRow, 23) = json("x")(1)("promo")
res(arrayRow, 24) = json("x")(1)("value_loc")
res(arrayRow, 25) = json("x")(1)("value_usd")
res(arrayRow, 26) = json("x")(1)("cost_loc")
res(arrayRow, 27) = json("x")(1)("cost_usd")
res(arrayRow, 28) = json("x")(1)("units")
res(arrayRow, 29) = json("x")(1)("version")
res(arrayRow, 30) = json("x")(1)("iter")
res(arrayRow, 31) = json("x")(1)("logid")
res(arrayRow, 32) = json("x")(1)("tag")
res(arrayRow, 33) = json("x")(1)("comment")
res(arrayRow, 34) = json("x")(1)("pounds")
json("x").Remove 1
arrayRow = arrayRow + 1
If jsonRow Mod batchSize = 0 Or json("x").Count = 0 Then
Application.StatusBar = "Populating spreadsheet: " & Format(jsonRow, "#,##0") & " of " & Format(totalRows, "#,##0") & " rows..."
Call Utils.SHTp_DumpVar(res, shData.Name, sheetRow, 1, False, True, True)
sheetRow = sheetRow + batchSize
End If
jsonRow = jsonRow + 1
Loop
Set json = Nothing
Application.StatusBar = False
End Sub
Sub pull_rep()
openf.Show
End Sub
Function request_adjust(doc As String, ByRef msg As String) As Boolean
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
request_adjust = False
If doc = "" Then
msg = "No data was given to be processed."
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
Debug.Print "GET /"; json("type"); " (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
If Mid(wr, 2, 5) = "error" Or _
Mid(wr, 1, 6) = "<body>" Or _
Mid(wr, 1, 6) = "<!DOCT" _
Then
msg = wr
Exit Function
End If
If Mid(wr, 1, 6) = "null" Then
msg = "API route not implemented"
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
msg = "No adjustment was made."
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
request_adjust = True
i = shData.UsedRange.Rows.Count + 1
Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True)
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 Long
Dim j As Long
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
Debug.Print "GET /list_changes (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
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 Long
Dim j As Long
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
Debug.Print "GET /undo_change (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
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
Debug.Print "GET /swap_fit (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
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
Reference in New Issue View Git Blame Copy Permalink