VBA/handler.bas

446 lines
13 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 x As New TheBigOne
Public wapi As New Windows_API
Public data() As String
Public agg() As String
Public showprice As Boolean
Public server As String
Public basis() As Variant
Public baseline() As Variant
Public adjust() As Variant
Sub load_fpvt()
Application.StatusBar = "retrieving selection data....."
'data = x.SHTp_Get("data", 1, 1, True)
'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30))
Dim i As Long
Dim s_tot As Object
fpvt.ListBox1.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 wapi As New Windows_API
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
Set json = JsonConverter.ParseJson(wr)
ReDim res(json("x").Count, 32)
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_descr")
res(i, 6) = json("x")(i)("segm")
res(i, 7) = json("x")(i)("mod_chan")
res(i, 8) = json("x")(i)("mod_chansub")
res(i, 9) = json("x")(i)("majg_descr")
res(i, 10) = json("x")(i)("ming_descr")
res(i, 11) = json("x")(i)("majs_descr")
res(i, 12) = json("x")(i)("mins_descr")
res(i, 13) = json("x")(i)("brand")
res(i, 14) = json("x")(i)("part_family")
res(i, 15) = json("x")(i)("part_group")
res(i, 16) = json("x")(i)("branding")
res(i, 17) = json("x")(i)("color")
res(i, 18) = json("x")(i)("part_descr")
res(i, 19) = json("x")(i)("order_season")
res(i, 20) = json("x")(i)("order_month")
res(i, 21) = json("x")(i)("ship_season")
res(i, 22) = json("x")(i)("ship_month")
res(i, 23) = json("x")(i)("request_season")
res(i, 24) = json("x")(i)("request_month")
res(i, 25) = json("x")(i)("promo")
res(i, 26) = json("x")(i)("version")
res(i, 27) = json("x")(i)("iter")
res(i, 28) = json("x")(i)("value_loc")
res(i, 29) = json("x")(i)("value_usd")
res(i, 30) = json("x")(i)("cost_loc")
res(i, 31) = json("x")(i)("cost_usd")
res(i, 32) = json("x")(i)("units")
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_descr"
res(0, 6) = "segm"
res(0, 7) = "mod_chan"
res(0, 8) = "mod_chansub"
res(0, 9) = "majg_descr"
res(0, 10) = "ming_descr"
res(0, 11) = "majs_descr"
res(0, 12) = "mins_descr"
res(0, 13) = "brand"
res(0, 14) = "part_family"
res(0, 15) = "part_group"
res(0, 16) = "branding"
res(0, 17) = "color"
res(0, 18) = "part_descr"
res(0, 19) = "order_season"
res(0, 20) = "order_month"
res(0, 21) = "ship_season"
res(0, 22) = "ship_month"
res(0, 23) = "request_season"
res(0, 24) = "request_month"
res(0, 25) = "promo"
res(0, 26) = "version"
res(0, 27) = "iter"
res(0, 28) = "value_loc"
res(0, 29) = "value_usd"
res(0, 30) = "cost_loc"
res(0, 31) = "cost_usd"
res(0, 32) = "units"
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
Call x.SHTp_Dump(str, "data", 1, 1, True, False, 28, 29, 30, 31, 32)
End Sub
Sub pull_rep()
openf.Show
End Sub
Function request_adjust(doc As String) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Integer
Dim j As Integer
Dim str() As String
Set json = JsonConverter.ParseJson(doc)
server = Sheets("config").Cells(1, 2)
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)
Exit Function
End If
If Mid(wr, 1, 6) = "<body>" Then
MsgBox (wr)
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no adjustment was made")
Exit Function
End If
ReDim res(json("x").Count - 1, 32)
For i = 1 To UBound(res, 1) + 1
res(i - 1, 0) = json("x")(i)("bill_cust_descr")
res(i - 1, 1) = json("x")(i)("billto_group")
res(i - 1, 2) = json("x")(i)("ship_cust_descr")
res(i - 1, 3) = json("x")(i)("shipto_group")
res(i - 1, 4) = json("x")(i)("quota_rep_descr")
res(i - 1, 5) = json("x")(i)("director_descr")
res(i - 1, 6) = json("x")(i)("segm")
res(i - 1, 7) = json("x")(i)("mod_chan")
res(i - 1, 8) = json("x")(i)("mod_chansub")
res(i - 1, 9) = json("x")(i)("majg_descr")
res(i - 1, 10) = json("x")(i)("ming_descr")
res(i - 1, 11) = json("x")(i)("majs_descr")
res(i - 1, 12) = json("x")(i)("mins_descr")
res(i - 1, 13) = json("x")(i)("brand")
res(i - 1, 14) = json("x")(i)("part_family")
res(i - 1, 15) = json("x")(i)("part_group")
res(i - 1, 16) = json("x")(i)("branding")
res(i - 1, 17) = json("x")(i)("color")
res(i - 1, 18) = json("x")(i)("part_descr")
res(i - 1, 19) = json("x")(i)("order_season")
res(i - 1, 20) = json("x")(i)("order_month")
res(i - 1, 21) = json("x")(i)("ship_season")
res(i - 1, 22) = json("x")(i)("ship_month")
res(i - 1, 23) = json("x")(i)("request_season")
res(i - 1, 24) = json("x")(i)("request_month")
res(i - 1, 25) = json("x")(i)("promo")
res(i - 1, 26) = json("x")(i)("version")
res(i - 1, 27) = json("x")(i)("iter")
res(i - 1, 28) = json("x")(i)("value_loc")
res(i - 1, 29) = json("x")(i)("value_usd")
res(i - 1, 30) = json("x")(i)("cost_loc")
res(i - 1, 31) = json("x")(i)("cost_usd")
res(i - 1, 32) = json("x")(i)("units")
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
Do Until Sheets("data").Cells(i, 1) = ""
i = i + 1
Loop
Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
End Function
Sub load_config()
Dim i As Integer
Dim j As Integer
'----server to use---------------------------------------------------------
handler.server = Sheets("config").Cells(1, 2)
'---basis-----------------------------------------------------------------
ReDim handler.basis(100)
i = 2
j = 0
Do While Sheets("config").Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.basis(j - 1)
'---baseline-----------------------------------------------------------------
ReDim handler.baseline(100)
i = 2
j = 0
Do While Sheets("config").Cells(3, i) <> ""
handler.baseline(j) = Sheets("config").Cells(3, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.baseline(j - 1)
'---adjustments-----------------------------------------------------------------
ReDim handler.adjust(100)
i = 2
j = 0
Do While Sheets("config").Cells(4, i) <> ""
handler.adjust(j) = Sheets("config").Cells(4, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.adjust(j - 1)
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
Dim sh As Worksheet
Set sh = Sheets("_month")
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
sh.Cells(1, 16) = JsonConverter.ConvertToJson(j)
For i = 0 To 12
'------------volume-------------------
sh.Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
sh.Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
sh.Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
sh.Cells(i + 1, 4) = 0
sh.Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
'------------value----------------------
sh.Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
sh.Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
sh.Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
sh.Cells(i + 1, 14) = 0
sh.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
sh.Cells(i + 1, 6) = 0
Else
sh.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 sh.Cells(i, 7) <> 0 Then
sh.Cells(i + 1, 7) = sh.Cells(i, 7)
Else
sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
'--adjust--
If (pkg(i, 3) + pkg(i, 2)) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.Cells(i + 1, 8) = (pkg(i, 7) + pkg(i, 6)) / (pkg(i, 3) + pkg(i, 2)) - (pkg(i, 6) / pkg(i, 2))
End If
'--current adjust--
sh.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 sh.Cells(i, 10) <> 0 Then
sh.Cells(i + 1, 10) = sh.Cells(i, 10)
Else
sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
End If
Next i
'scenario
Sheets("_month").Range("R1:S1000").ClearContents
For i = 0 To UBound(handler.sc, 1)
sh.Cells(i + 1, 18) = handler.sc(i, 0)
sh.Cells(i + 1, 19) = handler.sc(i, 1)
Next i
'basket
sh.Range("U1:AC100000").ClearContents
Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
Sheets("config").Cells(5, 2) = 0
months.load_sheet
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