VBA/handler.bas

403 lines
11 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-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-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)
With req
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
Sub month_tosheet(ByRef pkg() As Variant)
Dim i As Integer
Dim sh As Worksheet
Set sh = Sheets("_month")
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
sh.Cells(i + 1, 7) = 0
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
'--adjust--
If co_num(pkg(i, 3), 0) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.Cells(i + 1, 8) = pkg(i, 7) / pkg(i, 3)
End If
'--current adjust--
sh.Cells(i + 1, 9) = 0
'--forecast--
If co_num(pkg(i, 4), 0) = 0 Then
sh.Cells(i + 1, 10) = 0
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
End If
Next i
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