VBA/handler.bas
2020-02-18 17:04:03 -05:00

589 lines
17 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 plan 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
If Mid(wr, 1, 1) <> "{" Then
MsgBox (wr)
Exit Sub
End If
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")
res(i, 6) = json("x")(i)("segm")
res(i, 7) = json("x")(i)("chan")
res(i, 8) = json("x")(i)("chansub")
res(i, 9) = json("x")(i)("part_descr")
res(i, 10) = json("x")(i)("part_group")
res(i, 11) = json("x")(i)("branding")
res(i, 12) = json("x")(i)("majg_descr")
res(i, 13) = json("x")(i)("ming_descr")
res(i, 14) = json("x")(i)("majs_descr")
res(i, 15) = json("x")(i)("mins_descr")
res(i, 16) = json("x")(i)("order_season")
res(i, 17) = json("x")(i)("order_month")
res(i, 18) = json("x")(i)("ship_season")
res(i, 19) = json("x")(i)("ship_month")
res(i, 20) = json("x")(i)("request_season")
res(i, 21) = json("x")(i)("request_month")
res(i, 22) = json("x")(i)("promo")
res(i, 23) = json("x")(i)("value_loc")
res(i, 24) = json("x")(i)("value_usd")
res(i, 25) = json("x")(i)("cost_loc")
res(i, 26) = json("x")(i)("cost_usd")
res(i, 27) = json("x")(i)("units")
res(i, 28) = json("x")(i)("version")
res(i, 29) = json("x")(i)("iter")
res(i, 30) = json("x")(i)("logid")
res(i, 31) = json("x")(i)("tag")
res(i, 32) = json("x")(i)("comment")
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"
res(0, 6) = "segm"
res(0, 7) = "chan"
res(0, 8) = "chansub"
res(0, 9) = "part_descr"
res(0, 10) = "part_group"
res(0, 11) = "branding"
res(0, 12) = "majg_descr"
res(0, 13) = "ming_descr"
res(0, 14) = "majs_descr"
res(0, 15) = "mins_descr"
res(0, 16) = "order_season"
res(0, 17) = "order_month"
res(0, 18) = "ship_season"
res(0, 19) = "ship_month"
res(0, 20) = "request_season"
res(0, 21) = "request_month"
res(0, 22) = "promo"
res(0, 23) = "value_loc"
res(0, 24) = "value_usd"
res(0, 25) = "cost_loc"
res(0, 26) = "cost_usd"
res(0, 27) = "units"
res(0, 28) = "version"
res(0, 29) = "iter"
res(0, 30) = "logid"
res(0, 31) = "tag"
res(0, 32) = "comment"
Set json = Nothing
ReDim str(UBound(res, 1), UBound(res, 2))
Worksheets("data").Cells.ClearContents
Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True)
End Sub
Sub pull_rep()
openf.Show
End Sub
Function request_adjust(doc As String, ByRef fail As Boolean) As Object
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
If doc = "" Then
fail = True
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 = 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)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "<body>" Then
MsgBox (wr)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "<!DOCT" Then
MsgBox (wr)
fail = True
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no adjustment was made")
fail = True
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")
res(i - 1, 6) = json("x")(i)("segm")
res(i - 1, 7) = json("x")(i)("chan")
res(i - 1, 8) = json("x")(i)("chansub")
res(i - 1, 9) = json("x")(i)("part_descr")
res(i - 1, 10) = json("x")(i)("part_group")
res(i - 1, 11) = json("x")(i)("branding")
res(i - 1, 12) = json("x")(i)("majg_descr")
res(i - 1, 13) = json("x")(i)("ming_descr")
res(i - 1, 14) = json("x")(i)("majs_descr")
res(i - 1, 15) = json("x")(i)("mins_descr")
res(i - 1, 16) = json("x")(i)("order_season")
res(i - 1, 17) = json("x")(i)("order_month")
res(i - 1, 18) = json("x")(i)("ship_season")
res(i - 1, 19) = json("x")(i)("ship_month")
res(i - 1, 20) = json("x")(i)("request_season")
res(i - 1, 21) = json("x")(i)("request_month")
res(i - 1, 22) = json("x")(i)("promo")
res(i - 1, 23) = json("x")(i)("value_loc")
res(i - 1, 24) = json("x")(i)("value_usd")
res(i - 1, 25) = json("x")(i)("cost_loc")
res(i - 1, 26) = json("x")(i)("cost_usd")
res(i - 1, 27) = json("x")(i)("units")
res(i - 1, 28) = json("x")(i)("version")
res(i - 1, 29) = json("x")(i)("iter")
res(i - 1, 30) = json("x")(i)("logid")
res(i - 1, 31) = json("x")(i)("tag")
res(i - 1, 32) = json("x")(i)("comment")
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
i = 1
Do Until Sheets("data").Cells(i, 1) = ""
i = i + 1
Loop
Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True)
'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)
'---plan version--------------------------------------------------------------
handler.plan = Sheets("config").Cells(9, 2)
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
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 7) = 0
Else
sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
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 Or pkg(i, 2) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.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--
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
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 10) = 0
Else
sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
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
Sheets("config").Cells(6, 2) = 0
Sheets("config").Cells(7, 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
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 Integer
Dim j As Integer
Dim res() As Variant
If doc = "" Then
fail = True
Exit Function
End If
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/list_changes", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
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, 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)("def")
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 Integer
Dim j As Integer
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
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
logid = json("x")(1)("id")
'---------loop through and get a list of each row that needs deleted?-----
Set ds = Sheets("data")
j = 0
For i = 1 To 100
If ds.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
While ds.Cells(i, 1) <> ""
If ds.Cells(i, j) = logid Then
ds.Rows(i).Delete
Else
i = i + 1
End If
Wend
End Function
Sub history()
changes.Show
End Sub