VBA/handler.bas

446 lines
13 KiB
QBasic
Raw Normal View History

2019-03-05 16:18:02 -05:00
Attribute VB_Name = "handler"
2019-02-27 19:49:25 -05:00
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
2019-02-28 01:47:56 -05:00
Public data() As String
Public agg() As String
Public showprice As Boolean
2019-03-05 11:41:11 -05:00
Public server As String
2019-03-14 13:52:41 -04:00
Public basis() As Variant
Public baseline() As Variant
Public adjust() As Variant
2019-02-27 19:49:25 -05:00
Sub load_fpvt()
2019-03-05 11:41:11 -05:00
Application.StatusBar = "retrieving selection data....."
2019-02-28 01:47:56 -05:00
'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
2019-03-05 16:18:02 -05:00
2019-02-28 01:47:56 -05:00
2019-02-27 19:49:25 -05:00
fpvt.Show
2019-03-05 16:18:02 -05:00
2019-02-27 19:49:25 -05:00
End Sub
2019-03-05 11:41:11 -05:00
Function scenario_package(doc As String, ByRef status As Boolean) As Object
2019-02-28 01:47:56 -05:00
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
2019-03-05 11:41:11 -05:00
On Error GoTo errh
2019-02-28 01:47:56 -05:00
With req
2019-03-19 01:03:43 -04:00
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
2019-03-05 11:41:11 -05:00
.Open "GET", server & "/scenario_package", True
2019-02-28 01:47:56 -05:00
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
2019-03-05 11:41:11 -05:00
Set scenario_package = json
errh:
If Err.Number <> 0 Then
status = False
MsgBox (Err.Description)
Set scenario_package = Nothing
Else
status = True
End If
2019-02-28 01:47:56 -05:00
End Function
2019-03-05 11:41:11 -05:00
Sub pg_main_workset(rep As String)
2019-02-27 19:49:25 -05:00
Dim req As New WinHttp.WinHttpRequest
Dim wapi As New Windows_API
Dim wr As String
Dim json As Object
Dim i As Long
2019-02-27 20:34:59 -05:00
Dim j As Long
2019-02-27 19:49:25 -05:00
Dim doc As String
2019-02-27 20:34:59 -05:00
Dim res() As Variant
Dim str() As String
2019-02-27 19:49:25 -05:00
2019-03-05 11:41:11 -05:00
doc = "{""quota_rep"":""" & rep & """}"
2019-02-27 19:49:25 -05:00
With req
2019-03-20 01:43:18 -04:00
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
2019-03-14 13:52:41 -04:00
.Open "GET", handler.server & "/get_pool", True
2019-02-27 19:49:25 -05:00
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
2019-02-27 20:34:59 -05:00
ReDim res(json("x").Count, 32)
2019-02-27 19:49:25 -05:00
2019-03-05 11:41:11 -05:00
For i = 1 To UBound(res, 1)
2019-02-28 01:47:56 -05:00
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")
2019-02-27 20:34:59 -05:00
Next i
2019-02-28 01:47:56 -05:00
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"
2019-02-27 20:34:59 -05:00
Set json = Nothing
2019-02-27 19:49:25 -05:00
ReDim str(UBound(res, 1), UBound(res, 2))
2019-02-27 20:34:59 -05:00
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
2019-02-28 01:47:56 -05:00
Call x.SHTp_Dump(str, "data", 1, 1, True, False, 28, 29, 30, 31, 32)
2019-03-06 06:29:20 -05:00
2019-02-27 19:49:25 -05:00
End Sub
2019-03-05 11:41:11 -05:00
Sub pull_rep()
openf.Show
End Sub
2019-03-06 06:29:20 -05:00
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)
2019-03-20 01:43:18 -04:00
server = Sheets("config").Cells(1, 2)
2019-03-06 06:29:20 -05:00
With req
2019-03-19 16:46:56 -04:00
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
2019-03-14 13:52:41 -04:00
.Open "POST", server & "/" & json("type"), True
2019-03-06 06:29:20 -05:00
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
2019-03-14 13:52:41 -04:00
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
2019-03-06 06:29:20 -05:00
Set json = JsonConverter.ParseJson(wr)
2019-03-14 13:52:41 -04:00
If IsNull(json("x")) Then
MsgBox ("no adjustment was made")
Exit Function
End If
2019-03-06 06:29:20 -05:00
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
2019-03-14 13:52:41 -04:00
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
2019-03-15 10:44:45 -04:00
2019-03-19 01:03:43 -04:00
Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
2019-03-15 10:44:45 -04:00
Dim j As Object
2019-03-15 10:44:45 -04:00
Dim i As Integer
2019-03-19 01:03:43 -04:00
Dim r As Long
2019-03-15 10:44:45 -04:00
Dim sh As Worksheet
Set sh = Sheets("_month")
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
2019-03-15 16:42:58 -04:00
sh.Cells(1, 16) = JsonConverter.ConvertToJson(j)
2019-03-15 10:44:45 -04:00
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
2019-03-15 10:44:45 -04:00
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
'--adjust--
If (pkg(i, 3) + pkg(i, 2)) = 0 Then
2019-03-15 10:44:45 -04:00
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))
2019-03-15 10:44:45 -04:00
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
2019-03-15 10:44:45 -04:00
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
2019-03-15 10:44:45 -04:00
End If
2019-03-15 10:44:45 -04:00
Next i
2019-03-15 16:42:58 -04:00
2019-03-19 01:03:43 -04:00
'scenario
2019-03-19 10:57:56 -04:00
Sheets("_month").Range("R1:S1000").ClearContents
2019-03-19 01:03:43 -04:00
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
2019-03-19 15:43:31 -04:00
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)
2019-03-20 12:06:37 -04:00
Sheets("config").Cells(5, 2) = 0
2019-03-19 01:03:43 -04:00
2019-03-15 16:42:58 -04:00
months.load_sheet
2019-03-15 10:44:45 -04:00
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
2019-03-19 01:03:43 -04:00