pt/forecast_api
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
22c2375f44
forecast_api/Master Template.xlsm_EXPORTS/fpvt.frm
PhilRunninger 2454393a1d DRY up the WinHttpRequest calls. One sub now does it all. 
Instead of having multiple locations with the same code, the web
interface code now lives in its own module, and is called from multiple
locations.
2024-03-20 17:21:08 -04:00

568 lines
15 KiB
Plaintext
Raw Blame History

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
Caption = "Forecast Adjustment"
ClientHeight = 8490.001
ClientLeft = 120
ClientTop = 465
ClientWidth = 8670.001
OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "fpvt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private month() As Variant
Private adjust As Object
Private load_tb As Boolean
Private set_Price As Boolean
Private sp As Object
Private bVol As Double
Private bVal As Double
Private bPrc As Double
Private pVol As Double
Private pVal As Double
Private pPrc As Double
Private aVol As Double
Private aVal As Double
Private aPrc As Double
Private fVol As Double
Private fVal As Double
Private fPrc As Double
'=====================================================================================================
' Developers' backdoor to enter or exit debug mode: Ctrl-RightClick on the "Selected Scenario"
' label at the top of the form. Debug Mode shows the Pending Changes tab in the form, as well
' as all hidden sheets.
Private Sub Label62_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 And Shift = 2 Then
shConfig.Range("debug_mode") = Not shConfig.Range("debug_mode")
mp.Pages("pAPIDOC").Visible = shConfig.Range("debug_mode")
End If
End Sub
'=====================================================================================================
Private Sub butAdjust_Click()
Dim errorMsg As String
If tbAPI.text = "" Then errorMsg = "No adjustments provided."
If cbTAG.text = "" Then errorMsg = "No tag was selected."
If tbAPI.text = "" Then errorMsg = "No adjustements are ready."
If errorMsg <> "" Then
MsgBox errorMsg, vbOKOnly Or vbExclamation
Exit Sub
End If
handler.request_adjust tbAPI.text, errorMsg
If errorMsg <> "" Then
MsgBox errorMsg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error."
Exit Sub
End If
Me.tbCOM = ""
Me.cbTAG.text = ""
Me.Hide
Set adjust = Nothing
End Sub
Private Sub butCancel_Click()
Me.Hide
End Sub
Private Sub cbGoSheet_Click()
Dim tags
tags = RangeToArray(shConfig.ListObjects("TAGS").DataBodyRange)
If UBound(tags, 1) = 1 Then
shMonthView.Range("MonthTag").Value = tags(1, 1)
Else
shMonthView.Range("MonthTag").Value = ""
End If
shMonthView.Range("MonthComment").Value = ""
shMonthView.Range("QtyPctChange").Value = 0
shMonthView.Range("PricePctChange").Value = 0
shMonthView.Visible = xlSheetVisible
shMonthView.Select
Me.Hide
End Sub
Private Sub cbTAG_Change()
Dim j As Object
If tbAPI.text = "" Then tbAPI.text = "{}"
Set j = JsonConverter.ParseJson(tbAPI.text)
j("tag") = cbTAG.Value
tbAPI.text = JsonConverter.ConvertToJson(j)
End Sub
Private Sub opEditPrice_Click()
opPlugVol.Visible = False
opPlugPrice.Visible = False
' opPlugPrice.Value = True
' opPlugVol.Value = False
tbFcPrice.Enabled = True
tbFcPrice.BackColor = &H80000018
tbFcVal.Enabled = False
tbFcVal.BackColor = &H80000005
tbFcVol.Enabled = True
tbFcVol.BackColor = &H80000018
sbpv.Enabled = True
sbpp.Enabled = True
sbpd.Enabled = False
tbpv.Enabled = True
tbpp.Enabled = True
tbpd.Enabled = False
End Sub
Private Sub opEditSales_Click()
opPlugVol.Visible = True
opPlugPrice.Visible = True
tbFcPrice.Enabled = False
tbFcPrice.BackColor = &H80000005
tbFcVal.Enabled = True
tbFcVal.BackColor = &H80000018
tbFcVol.Enabled = False
tbFcVol.BackColor = &H80000005
sbpv.Enabled = False
sbpp.Enabled = False
sbpd.Enabled = True
tbpv.Enabled = False
tbpp.Enabled = False
tbpd.Enabled = True
End Sub
Private Sub opPlugPrice_Click()
calc_val
End Sub
Private Sub opPlugVol_Click()
calc_val
End Sub
Private Sub sbpd_Change()
tbpd.Value = sbpd.Value
End Sub
Private Sub sbpp_Change()
tbpp.Value = sbpp.Value
End Sub
Private Sub sbpv_Change()
tbpv.Value = sbpv.Value
End Sub
Private Sub tbCOM_Change()
If tbAPI.text = "" Then tbAPI.text = "{}"
Set adjust = JsonConverter.ParseJson(tbAPI.text)
adjust("message") = tbCOM.text
tbAPI.text = JsonConverter.ConvertToJson(adjust)
End Sub
Private Sub tbFcPrice_Change()
If load_tb Then Exit Sub
set_Price = True
If opEditPrice Then calc_price
set_Price = False
End Sub
Private Sub tbFcVal_Change()
If load_tb Then Exit Sub
If opEditSales Then calc_val
End Sub
Private Sub tbFcVol_Change()
If load_tb Then Exit Sub
If opEditPrice Then calc_price
End Sub
Private Sub tbpd_Change()
If load_tb Then Exit Sub
If Not VBA.IsNumeric(tbpd.Value) Then Exit Sub
tbFcVal = (bVal + pVal) * (1 + tbpd.Value / 100)
End Sub
Private Sub tbpp_Change()
If load_tb Then Exit Sub
If Not VBA.IsNumeric(tbpd.Value) Then Exit Sub
tbFcPrice = (bPrc + pPrc) * (1 + tbpp.Value / 100)
Me.load_mbox_ann
End Sub
Private Sub tbpv_Change()
If load_tb Then Exit Sub
If Not VBA.IsNumeric(tbpv.Value) Then Exit Sub
tbFcVol = (bVol + pVol) * (1 + tbpv.Value / 100)
End Sub
Private Sub UserForm_Activate()
Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value & " Loading..."
Me.mp.Visible = False
Me.fraExit.Visible = False
Dim errorMsg As String
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", errorMsg)
Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value
If errorMsg <> "" Then
fpvt.Hide
Application.StatusBar = False
Exit Sub
End If
'---show existing adjustment if there is one----
pVol = 0
pVal = 0
pPrc = 0
bVol = 0
bVal = 0
bPrc = 0
aVol = 0
aVal = 0
aPrc = 0
fVal = 0
fVol = 0
fPrc = 0
Me.tbAPI.Value = ""
If IsNull(sp("package")("totals")) Then
MsgBox "An unexpected error has occurred when retrieving the scenario.", vbOKOnly Or vbExclamation, "Error"
fpvt.Hide
Application.StatusBar = False
Exit Sub
End If
Dim i As Long
For i = 1 To sp("package")("totals").Count
Select Case sp("package")("totals")(i)("order_season")
Case 2025
Select Case Me.iter_def(sp("package")("totals")(i)("iter"))
Case "baseline"
bVol = bVol + sp("package")("totals")(i)("units")
bVal = bVal + sp("package")("totals")(i)("value_usd")
If bVol <> 0 Then bPrc = bVal / bVol
Case "adjust"
pVol = pVol + sp("package")("totals")(i)("units")
pVal = pVal + sp("package")("totals")(i)("value_usd")
Case "exclude"
End Select
End Select
Next i
fVol = bVol + pVol
fVal = bVal + pVal
If fVol = 0 Then
fPrc = 0
Else
fPrc = fVal / fVol
End If
If (bVol + pVol) = 0 Then
pPrc = 0
Else
If bVol = 0 Then
pPrc = 0
Else
pPrc = (pVal + bVal) / (bVol + pVol) - bVal / bVol
End If
End If
If aVal <> 0 Then
MsgBox aVal
End If
Me.load_mbox_ann
'---------------------------------------populate monthly-------------------------------------------------------
'--parse json into variant array for loading--
ReDim month(sp("package")("mpvt").Count + 1, 10)
For i = 1 To sp("package")("mpvt").Count
month(i, 0) = sp("package")("mpvt")(i)("order_month")
month(i, 1) = sp("package")("mpvt")(i)("2024 qty")
month(i, 2) = sp("package")("mpvt")(i)("2025 base qty")
month(i, 3) = sp("package")("mpvt")(i)("2025 adj qty")
month(i, 4) = sp("package")("mpvt")(i)("2025 tot qty")
month(i, 5) = sp("package")("mpvt")(i)("2024 value_usd")
month(i, 6) = sp("package")("mpvt")(i)("2025 base value_usd")
month(i, 7) = sp("package")("mpvt")(i)("2025 adj value_usd")
month(i, 8) = sp("package")("mpvt")(i)("2025 tot value_usd")
If co_num(month(i, 2), 0) = 0 Then
month(i, 9) = "addmonth"
Else
month(i, 9) = "scale"
End If
Next i
Me.crunch_array
ReDim basket(sp("package")("basket").Count, 3)
basket(0, 0) = "part_descr"
basket(0, 1) = "bill_cust_descr"
basket(0, 2) = "ship_cust_descr"
basket(0, 3) = "mix"
For i = 1 To UBound(basket, 1)
basket(i, 0) = sp("package")("basket")(i)("part_descr")
basket(i, 1) = sp("package")("basket")(i)("bill_cust_descr")
basket(i, 2) = sp("package")("basket")(i)("ship_cust_descr")
basket(i, 3) = sp("package")("basket")(i)("mix")
Next i
'-------------load tags-------------------------------
cbTAG.list = RangeToArray(shConfig.ListObjects("TAGS").DataBodyRange)
If cbTAG.ListCount = 1 Then
cbTAG.ListIndex = 0
End If
'----------reset spinner buttons----------------------
sbpv.Value = 0
sbpp.Value = 0
sbpd.Value = 0
Call handler.month_tosheet(month, basket)
Application.StatusBar = False
Me.mp.Visible = True
Me.fraExit.Visible = True
End Sub
Sub crunch_array()
Dim i As Integer
month(13, 1) = 0
month(13, 2) = 0
month(13, 3) = 0
month(13, 4) = 0
month(13, 5) = 0
month(13, 6) = 0
month(13, 7) = 0
month(13, 8) = 0
For i = 1 To 12
month(13, 1) = month(13, 1) + co_num(month(i, 1), 0)
month(13, 2) = month(13, 2) + co_num(month(i, 2), 0)
month(13, 3) = month(13, 3) + co_num(month(i, 3), 0)
month(13, 4) = month(13, 4) + co_num(month(i, 4), 0)
month(13, 5) = month(13, 5) + co_num(month(i, 5), 0)
month(13, 6) = month(13, 6) + co_num(month(i, 6), 0)
month(13, 7) = month(13, 7) + co_num(month(i, 7), 0)
month(13, 8) = month(13, 8) + co_num(month(i, 8), 0)
Next i
ReDim mload(UBound(month, 1), 5)
For i = 0 To UBound(month, 1)
mload(i, 0) = month(i, 0)
mload(i, 1) = Format(month(i, 1), "#,###")
mload(i, 2) = Format(month(i, 4), "#,###")
mload(i, 3) = Format(month(i, 5), "#,###")
mload(i, 4) = Format(month(i, 8), "#,###")
Next i
End Sub
Public Function rev_cust(cust As String) As String
If cust = "" Then
rev_cust = ""
Exit Function
End If
If InStr(1, cust, " - ") <= 9 Then
rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8))
Else
rev_cust = trim(Right(cust, 8)) & " - " & Mid(cust, 1, InStr(1, cust, " - "))
End If
End Function
Sub load_mbox_ann()
load_tb = True
tbBaseVol = Format(bVol, "#,##0")
tbBaseVal = Format(bVal, "#,##0")
tbBasePrice = Format(bPrc, "0.00000")
tbPadjVol = Format(pVol, "#,##0")
tbPadjVal = Format(pVal, "#,##0")
tbPadjPrice = Format(pPrc, "0.00000")
tbFcVol = Format(fVol, "#,##0")
tbFcVal = Format(fVal, "#,##0")
If Not set_Price Then tbFcPrice = Format(fPrc, "0.00000")
tbAdjVol = Format(aVol, "#,##0")
tbAdjVal = Format(aVal, "#,##0")
tbAdjPrice = Format(aPrc, "0.00000")
load_tb = False
End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
If Not IsNumeric(one) Or IsNull(one) Then
co_num = two
Else
co_num = one
End If
End Function
Sub calc_val()
Dim pchange As Double
If IsNumeric(tbFcVal.Value) Then
'get textbox value
fVal = tbFcVal.Value
'do calculations
aVal = fVal - bVal - pVal
'---------if volume adjustment method is selected, scale the volume up----------------------------------
If opPlugVol Then
If (Round(pVal, 2) + Round(bVal, 2)) = 0 Then
pchange = 0
If co_num(pVal, bVal) = 0 Then
MsgBox "Zero times any number is zero. Cannot scale to get to the target."
Else
fVol = fVal / (co_num(bVal, pVal) / co_num(bVol, pVol))
End If
Else
pchange = fVal / (pVal + bVal)
fVol = (pVol + bVol) * pchange
End If
Else
fVol = pVol + bVol
End If
If fVol = 0 Then
fPrc = 0
Else
fPrc = fVal / fVol
End If
aVol = fVol - (bVol + pVol)
aPrc = fPrc - (bPrc + pPrc)
Else
aVol = fVol - bVol - pVol
aPrc = 0
End If
tbFcVal = Format(co_num(tbFcVal, 0), "#,##0")
Me.load_mbox_ann
'build json
Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
adjust("scenario")("version") = handler.plan
adjust("scenario")("iter") = handler.basis
adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
adjust("user") = Application.UserName
adjust("source") = "adj"
adjust("message") = tbCOM.text
adjust("tag") = cbTAG.text
If opEditSales Then
If opPlugVol Then
adjust("type") = "scale_v"
adjust("amount") = aVal
adjust("qty") = aVol
Else
adjust("type") = "scale_p"
adjust("amount") = aVal
End If
Else
adjust("type") = "scale_vp"
adjust("qty") = aVol
adjust("amount") = aVal
End If
'print json
tbAPI = JsonConverter.ConvertToJson(adjust)
End Sub
Sub calc_price()
fVol = co_num(tbFcVol.Value, 0)
fPrc = co_num(tbFcPrice.Value, 0)
'calc
fVal = fPrc * fVol
aVal = fVal - bVal - pVal
aVol = fVol - (bVol + pVol)
If (bVol + pVol) = 0 Then
aPrc = 0
Else
'aPrc = fVal / fVol - ((bVal + pVal) / (bVol + pVol))
aPrc = fPrc - (bPrc + pPrc)
End If
'End If
Me.load_mbox_ann
'build json
Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
adjust("scenario")("version") = handler.plan
adjust("scenario")("iter") = handler.basis
adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
adjust("user") = Application.UserName
adjust("source") = "adj"
adjust("message") = tbCOM.text
adjust("tag") = cbTAG.text
adjust("version") = handler.plan
If opEditSales Then
If opPlugVol Then
adjust("type") = "scale_v"
adjust("amount") = aVal
Else
adjust("type") = "scale_p"
adjust("amount") = aVal
End If
Else
If aVol = 0 Then
adjust("type") = "scale_p"
Else
adjust("type") = "scale_vp"
End If
adjust("qty") = aVol
adjust("amount") = aVal
End If
'print json
tbAPI = JsonConverter.ConvertToJson(adjust)
End Sub
Function iter_def(ByVal iter As String) As String
Dim i As Integer
For i = 0 To UBound(handler.baseline)
If handler.baseline(i) = iter Then
iter_def = "baseline"
Exit Function
End If
Next i
For i = 0 To UBound(handler.adjust)
If handler.adjust(i) = iter Then
iter_def = "adjust"
Exit Function
End If
Next i
iter_def = "exclude"
End Function
Reference in New Issue View Git Blame Copy Permalink