pt/forecast_api
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

DRY up the WinHttpRequest calls. One sub now does it all.

Browse Source 
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.
This commit is contained in:
PhilRunninger 2024-03-20 17:03:04 -04:00
parent c7789f868c
commit 2454393a1d
12 changed files with 130 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
Master Template.xlsm
View File

Binary file not shown.

66
Master Template.xlsm_EXPORTS/HttpHandler.bas Normal file
View File

@ -0,0 +1,66 @@
Attribute VB_Name = "HttpHandler"
Option Explicit
Function makeHttpRequest(method As String, route As String, doc As String, ByRef errorMsg As String) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim res() As Variant
On Error GoTo errHandler
Set makeHttpRequest = Nothing
If doc = "" Then
errorMsg = "No message to send to the server."
Exit Function
End If
Dim server As String
server = shConfig.Range("server").Value
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open method, server & "/" & route, True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
Debug.Print method & " /" & route & " (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
If Mid(wr, 1, 1) <> "{" Or _
Mid(wr, 2, 5) = "error" Or _
Mid(wr, 1, 6) = "<body>" Or _
Mid(wr, 1, 6) = "<!DOCT" _
Then
errorMsg = "Unexpected Result from Server: " & wr
Exit Function
End If
If Mid(wr, 1, 6) = "null" Then
errorMsg = "API route not implemented."
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
errorMsg = "Empty response from the server."
Exit Function
End If
Set makeHttpRequest = json
exitFunction:
' Any final clean-up goes here. This will get hit even after errHandler does its thing.
Exit Function
errHandler:
MsgBox Err.Description
Resume exitFunction
End Function

8
Master Template.xlsm_EXPORTS/Utils.bas
View File

@ -68,7 +68,7 @@ On Error GoTo errh
errh: errh:
If Err.Number <> 0 Then If Err.Number <> 0 Then
MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description) MsgBox "Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description
ADOo_errstring = Err.Description ADOo_errstring = Err.Description
End If End If
@ -192,7 +192,7 @@ On Error GoTo errh
errh: errh:
If Err.Number <> 0 Then If Err.Number <> 0 Then
MsgBox ("Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description) MsgBox "Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description
ADOo_errstring = Err.Description ADOo_errstring = Err.Description
Exit Function Exit Function
End If End If
@ -242,7 +242,7 @@ Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Lon
errhndl: errhndl:
If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description) If Err.Number <> 0 Then MsgBox "Error in dumping to sheet" & vbCrLf & Err.Description
End Sub End Sub
@ -317,7 +317,7 @@ Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As
errhdnl: errhdnl:
If Err.Number <> 0 Then If Err.Number <> 0 Then
MsgBox (Err.Description) MsgBox Err.Description
End If End If
SHTp_Get = table SHTp_Get = table

BIN
Master Template.xlsm_EXPORTS/build.frx
View File

Binary file not shown.

16
Master Template.xlsm_EXPORTS/changes.frm
View File

@ -18,11 +18,11 @@ Private X As Variant
Private Sub UserForm_Activate() Private Sub UserForm_Activate()
tbPrint.Value = "" tbPrint.Value = ""
Dim fail As Boolean Dim errorMsg As String
X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail) X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", errorMsg)
If fail Then If errorMsg <> "" Then
Unload Me Unload Me
MsgBox ("No adjustments have been made.") MsgBox "No adjustments have been made.", vbOKOnly + vbExclamation, errorMsg
End End
End If End If
Me.lbHist.list = X Me.lbHist.list = X
@ -51,7 +51,7 @@ End Sub
Sub delete_selected() Sub delete_selected()
Dim logid As Integer Dim logid As Integer
Dim i As Integer Dim i As Integer
Dim fail As Boolean Dim errorMsg As String
Dim proceed As Boolean Dim proceed As Boolean
If MsgBox("Permanently delete these changes?", vbYesNo) = vbNo Then If MsgBox("Permanently delete these changes?", vbYesNo) = vbNo Then
@ -60,9 +60,9 @@ Sub delete_selected()
For i = 0 To Me.lbHist.ListCount - 1 For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then If Me.lbHist.Selected(i) Then
Call handler.undo_changes(X(i, 6), fail) handler.undo_changes X(i, 6), errorMsg
If fail Then If errorMsg <> "" Then
MsgBox ("Undo did not work.") MsgBox errorMsg, vbOKOnly + vbCritical, "Undo did not work."
Exit Sub Exit Sub
End If End If
End If End If

BIN
Master Template.xlsm_EXPORTS/changes.frx
View File

Binary file not shown.

27
Master Template.xlsm_EXPORTS/fpvt.frm
View File

@ -47,20 +47,19 @@ End Sub
'===================================================================================================== '=====================================================================================================
Private Sub butAdjust_Click() Private Sub butAdjust_Click()
Dim fail As Boolean Dim errorMsg As String
Dim msg 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 tbAPI.text = "" Then msg = "No adjustments provided." If errorMsg <> "" Then
If cbTAG.text = "" Then msg = "No tag was selected." MsgBox errorMsg, vbOKOnly Or vbExclamation
If tbAPI.text = "" Then msg = "No adjustements are ready."
If msg <> "" Then
MsgBox msg, vbOKOnly Or vbExclamation
Exit Sub Exit Sub
End If End If
If Not handler.request_adjust(tbAPI.text, msg) Then handler.request_adjust tbAPI.text, errorMsg
MsgBox msg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error." If errorMsg <> "" Then
MsgBox errorMsg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error."
Exit Sub Exit Sub
End If End If
@ -208,13 +207,13 @@ Private Sub UserForm_Activate()
Me.mp.Visible = False Me.mp.Visible = False
Me.fraExit.Visible = False Me.fraExit.Visible = False
Dim ok As Boolean Dim errorMsg As String
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", errorMsg)
Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value
If Not ok Then If errorMsg <> "" Then
fpvt.Hide fpvt.Hide
Application.StatusBar = False Application.StatusBar = False
Exit Sub Exit Sub
@ -279,7 +278,7 @@ Private Sub UserForm_Activate()
End If End If
End If End If
If aVal <> 0 Then If aVal <> 0 Then
MsgBox (aVal) MsgBox aVal
End If End If
Me.load_mbox_ann Me.load_mbox_ann

BIN
Master Template.xlsm_EXPORTS/fpvt.frx
View File

Binary file not shown.

245
Master Template.xlsm_EXPORTS/handler.bas
View File

@ -40,76 +40,19 @@ Sub load_fpvt()
End Sub End Sub
Function scenario_package(doc As String, ByRef status As Boolean) As Object Function scenario_package(doc As String, ByRef errorMsg As String) As Object
Set scenario_package = makeHttpRequest("GET", "scenario_package", doc, errorMsg)
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
Debug.Print "GET /scenario_package (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
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 End Function
Sub pg_main_workset(catg As String, rep As String) Sub pg_main_workset(catg As String, rep As String)
Dim errorMsg As String
Dim req As New WinHttp.WinHttpRequest
Dim wr As String
Dim json As Object
Dim doc As String
Dim res() As Variant
doc = "{""scenario"":{""" & catg & """:""" & rep & """}}"
Application.StatusBar = "Querying for " & rep & "'s pool of data..." Application.StatusBar = "Querying for " & rep & "'s pool of data..."
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", handler.server & "/get_pool", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
Debug.Print "GET /get_pool (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
If Mid(wr, 1, 1) <> "{" Then Dim json As Object
MsgBox (wr) Set json = makeHttpRequest("GET", "get_pool", "{""scenario"":{""" & catg & """:""" & rep & """}}", errorMsg)
Exit Sub
End If
Application.StatusBar = "Parsing query results..." If errorMsg <> "" Then
Set json = JsonConverter.ParseJson(wr) MsgBox errorMsg, vbOKOnly + vbExclamation, "Couldn't " & rep & "'s pool of data."
If IsNull(json("x")) Then
MsgBox "No data found for " & rep & "."
Exit Sub Exit Sub
End If End If
@ -229,64 +172,18 @@ End Sub
Function request_adjust(doc As String, ByRef msg As String) As Boolean Sub request_adjust(doc As String, ByRef errorMsg As String)
Dim req As New WinHttp.WinHttpRequest
Dim json As Object Dim json As Object
Dim wr As String
Dim i As Long
Dim j As Long
Dim str() As String
request_adjust = False
If doc = "" Then
msg = "No data was given to be processed."
Exit Function
End If
'update timestamp
Set json = JsonConverter.ParseJson(doc) Set json = JsonConverter.ParseJson(doc)
'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss") Set json = makeHttpRequest("POST", json("type"), doc, errorMsg)
'doc = JsonConverter.ConvertToJson(doc)
server = shConfig.Range("server").Value If errorMsg <> "" Then
Exit Sub
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "POST", server & "/" & json("type"), True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
Debug.Print "GET /"; json("type"); " (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
If Mid(wr, 2, 5) = "error" Or _
Mid(wr, 1, 6) = "<body>" Or _
Mid(wr, 1, 6) = "<!DOCT" _
Then
msg = wr
Exit Function
End If
If Mid(wr, 1, 6) = "null" Then
msg = "API route not implemented"
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
msg = "No adjustment was made."
Exit Function
End If End If
ReDim res(json("x").Count - 1, 34) ReDim res(json("x").Count - 1, 34)
Dim i As Long
For i = 0 To UBound(res, 1) For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("bill_cust_descr") res(i, 0) = json("x")(i + 1)("bill_cust_descr")
res(i, 1) = json("x")(i + 1)("billto_group") res(i, 1) = json("x")(i + 1)("billto_group")
@ -325,13 +222,13 @@ Function request_adjust(doc As String, ByRef msg As String) As Boolean
res(i, 34) = json("x")(i + 1)("pounds") res(i, 34) = json("x")(i + 1)("pounds")
Next i Next i
request_adjust = True errorMsg = ""
i = shData.UsedRange.Rows.Count + 1 i = shData.UsedRange.Rows.Count + 1
Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True) Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True)
shOrders.PivotTables("ptOrders").PivotCache.Refresh shOrders.PivotTables("ptOrders").PivotCache.Refresh
End Function End Sub
Sub load_config() Sub load_config()
@ -481,44 +378,17 @@ Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
End Function End Function
Function list_changes(doc As String, ByRef fail As Boolean) As Variant() Function list_changes(doc As String, ByRef errorMsg As String) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object Dim json As Object
Dim wr As String Set json = makeHttpRequest("GET", "list_changes", doc, errorMsg)
Dim i As Long
Dim j As Long
Dim res() As Variant
If doc = "" Then If errorMsg <> "" Then
fail = True
Exit Function
End If
server = shConfig.Range("server").Value
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/list_changes", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
Debug.Print "GET /list_changes (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
fail = True
Exit Function Exit Function
End If End If
ReDim res(json("x").Count - 1, 7) ReDim res(json("x").Count - 1, 7)
Dim i As Long
For i = 0 To UBound(res, 1) For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("user") res(i, 0) = json("x")(i + 1)("user")
res(i, 1) = json("x")(i + 1)("quota_rep_descr") res(i, 1) = json("x")(i + 1)("quota_rep_descr")
@ -534,39 +404,16 @@ Function list_changes(doc As String, ByRef fail As Boolean) As Variant()
End Function End Function
Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant() Sub undo_changes(ByVal logid As Integer, ByRef errorMsg As String)
Dim req As New WinHttp.WinHttpRequest
Dim json As Object Dim json As Object
Dim wr As String Set json = makeHttpRequest("GET", "undo_change", "{""logid"":" & logid & "}", errorMsg)
Dim i As Long
Dim j As Long
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
Debug.Print "GET /undo_change (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
End With
Set json = JsonConverter.ParseJson(wr)
logid = json("x")(1)("id") logid = json("x")(1)("id")
'---------loop through and get a list of each row that needs deleted?----- '---------loop through and get a list of each row that needs deleted?-----
Dim i As Long
Dim j As Long
j = 0 j = 0
For i = 1 To 100 For i = 1 To 100
If shData.Cells(1, i) = "logid" Then If shData.Cells(1, i) = "logid" Then
@ -576,9 +423,8 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant(
Next i Next i
If j = 0 Then If j = 0 Then
MsgBox ("Current data set is not tracking changes. Cannot isolate change locally.") errorMsg = "Current data set is not tracking changes. Cannot isolate change locally."
fail = True Exit Sub
Exit Function
End If End If
i = 2 i = 2
@ -592,54 +438,21 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant(
Wend Wend
End With End With
End Function End Sub
Sub history() Sub history()
changes.Show changes.Show
End Sub End Sub
Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant() Function get_swap_fit(doc As String, ByRef errorMsg As String) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object Dim json As Object
Dim wr As String Set json = makeHttpRequest("GET", "swap_fit", doc, errorMsg)
Dim i As Integer
Dim j As Integer
Dim res() As Variant Dim res() As Variant
If doc = "" Then
fail = True
Exit Function
End If
server = shConfig.Range("server").Value
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/swap_fit", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
Debug.Print "GET /swap_fit (";
Dim t As Single
t = Timer
.WaitForResponse
wr = .ResponseText
Debug.Print Timer - t; "sec): "; Left(wr, 200)
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, 3) ReDim res(json("x").Count - 1, 3)
Dim i As Integer
For i = 0 To UBound(res, 1) For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("part") res(i, 0) = json("x")(i + 1)("part")
res(i, 1) = json("x")(i + 1)("value_usd") res(i, 1) = json("x")(i + 1)("value_usd")

BIN
Master Template.xlsm_EXPORTS/openf.frx
View File

Binary file not shown.

BIN
Master Template.xlsm_EXPORTS/part.frx
View File

Binary file not shown.

12
Master Template.xlsm_EXPORTS/shMonthView.cls
View File

@ -727,8 +727,11 @@ Sub post_adjust()
adjust("message") = shMonthView.Range("MonthComment").Value adjust("message") = shMonthView.Range("MonthComment").Value
adjust("tag") = shMonthView.Range("MonthTag").Value adjust("tag") = shMonthView.Range("MonthTag").Value
jdoc = JsonConverter.ConvertToJson(adjust) jdoc = JsonConverter.ConvertToJson(adjust)
If Not handler.request_adjust(jdoc, msg) Then
MsgBox msg, vbOKOnly Or vbCritical, "Adjustment was not made." Dim errorMsg As String
handler.request_adjust jdoc, errorMsg
If errorMsg <> "" Then
MsgBox errorMsg, vbOKOnly Or vbCritical, "Adjustment was not made."
Exit Sub Exit Sub
End If End If
Else Else
@ -739,7 +742,8 @@ Sub post_adjust()
adjust("message") = shMonthView.Range("MonthComment").Value adjust("message") = shMonthView.Range("MonthComment").Value
adjust("tag") = shMonthView.Range("MonthTag").Value adjust("tag") = shMonthView.Range("MonthTag").Value
jdoc = JsonConverter.ConvertToJson(adjust) jdoc = JsonConverter.ConvertToJson(adjust)
If Not handler.request_adjust(jdoc, msg) Then handler.request_adjust jdoc, errorMsg
If errorMsg <> "" Then
Dim period As String Dim period As String
period = Format(i - 1, "00") & " - " & Format(DateSerial(2000, (i - 1) + 5, 1), "mmm") period = Format(i - 1, "00") & " - " & Format(DateSerial(2000, (i - 1) + 5, 1), "mmm")
allMsg = IIf(allMsg = "", "", vbNewLine) & period & ": " & msg allMsg = IIf(allMsg = "", "", vbNewLine) & period & ": " & msg
@ -804,7 +808,7 @@ Sub new_part()
cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True) cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True)
If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then
MsgBox ("Error building customer mix.") MsgBox "Error building customer mix."
End If End If
'--------inquire for new part to join with cust mix-------------------------------------------- '--------inquire for new part to join with cust mix--------------------------------------------