diff --git a/Master Template.xlsm b/Master Template.xlsm index 71e6e2d..b41efe9 100644 Binary files a/Master Template.xlsm and b/Master Template.xlsm differ diff --git a/Master Template.xlsm_EXPORTS/HttpHandler.bas b/Master Template.xlsm_EXPORTS/HttpHandler.bas new file mode 100644 index 0000000..0cdedf8 --- /dev/null +++ b/Master Template.xlsm_EXPORTS/HttpHandler.bas @@ -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) = "" Or _ + Mid(wr, 1, 6) = " 0 Then - MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description) + MsgBox "Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description ADOo_errstring = Err.Description End If @@ -192,7 +192,7 @@ On Error GoTo errh errh: 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 Exit Function End If @@ -242,7 +242,7 @@ Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Lon 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 @@ -317,7 +317,7 @@ Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As errhdnl: If Err.Number <> 0 Then - MsgBox (Err.Description) + MsgBox Err.Description End If SHTp_Get = table diff --git a/Master Template.xlsm_EXPORTS/build.frx b/Master Template.xlsm_EXPORTS/build.frx index a52a995..1bef378 100644 Binary files a/Master Template.xlsm_EXPORTS/build.frx and b/Master Template.xlsm_EXPORTS/build.frx differ diff --git a/Master Template.xlsm_EXPORTS/changes.frm b/Master Template.xlsm_EXPORTS/changes.frm index 29bd6e6..e0f3d0e 100644 --- a/Master Template.xlsm_EXPORTS/changes.frm +++ b/Master Template.xlsm_EXPORTS/changes.frm @@ -18,11 +18,11 @@ Private X As Variant Private Sub UserForm_Activate() tbPrint.Value = "" - Dim fail As Boolean - X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail) - If fail Then + Dim errorMsg As String + X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", errorMsg) + If errorMsg <> "" Then Unload Me - MsgBox ("No adjustments have been made.") + MsgBox "No adjustments have been made.", vbOKOnly + vbExclamation, errorMsg End End If Me.lbHist.list = X @@ -51,7 +51,7 @@ End Sub Sub delete_selected() Dim logid As Integer Dim i As Integer - Dim fail As Boolean + Dim errorMsg As String Dim proceed As Boolean If MsgBox("Permanently delete these changes?", vbYesNo) = vbNo Then @@ -60,9 +60,9 @@ Sub delete_selected() For i = 0 To Me.lbHist.ListCount - 1 If Me.lbHist.Selected(i) Then - Call handler.undo_changes(X(i, 6), fail) - If fail Then - MsgBox ("Undo did not work.") + handler.undo_changes X(i, 6), errorMsg + If errorMsg <> "" Then + MsgBox errorMsg, vbOKOnly + vbCritical, "Undo did not work." Exit Sub End If End If diff --git a/Master Template.xlsm_EXPORTS/changes.frx b/Master Template.xlsm_EXPORTS/changes.frx index e862ef0..045d9d1 100644 Binary files a/Master Template.xlsm_EXPORTS/changes.frx and b/Master Template.xlsm_EXPORTS/changes.frx differ diff --git a/Master Template.xlsm_EXPORTS/fpvt.frm b/Master Template.xlsm_EXPORTS/fpvt.frm index d8a7aa0..788a1c7 100644 --- a/Master Template.xlsm_EXPORTS/fpvt.frm +++ b/Master Template.xlsm_EXPORTS/fpvt.frm @@ -47,20 +47,19 @@ End Sub '===================================================================================================== Private Sub butAdjust_Click() - Dim fail As Boolean - Dim msg As String + Dim errorMsg 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 cbTAG.text = "" Then msg = "No tag was selected." - If tbAPI.text = "" Then msg = "No adjustements are ready." - - If msg <> "" Then - MsgBox msg, vbOKOnly Or vbExclamation + If errorMsg <> "" Then + MsgBox errorMsg, vbOKOnly Or vbExclamation Exit Sub End If - If Not handler.request_adjust(tbAPI.text, msg) Then - MsgBox msg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error." + handler.request_adjust tbAPI.text, errorMsg + If errorMsg <> "" Then + MsgBox errorMsg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error." Exit Sub End If @@ -208,13 +207,13 @@ Private Sub UserForm_Activate() Me.mp.Visible = False Me.fraExit.Visible = False - Dim ok As Boolean - Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) + Dim errorMsg As String + Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", errorMsg) Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value - If Not ok Then + If errorMsg <> "" Then fpvt.Hide Application.StatusBar = False Exit Sub @@ -279,7 +278,7 @@ Private Sub UserForm_Activate() End If End If If aVal <> 0 Then - MsgBox (aVal) + MsgBox aVal End If Me.load_mbox_ann diff --git a/Master Template.xlsm_EXPORTS/fpvt.frx b/Master Template.xlsm_EXPORTS/fpvt.frx index afe05f7..3397bdf 100644 Binary files a/Master Template.xlsm_EXPORTS/fpvt.frx and b/Master Template.xlsm_EXPORTS/fpvt.frx differ diff --git a/Master Template.xlsm_EXPORTS/handler.bas b/Master Template.xlsm_EXPORTS/handler.bas index 881cd1b..724d167 100644 --- a/Master Template.xlsm_EXPORTS/handler.bas +++ b/Master Template.xlsm_EXPORTS/handler.bas @@ -40,76 +40,19 @@ Sub load_fpvt() 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 - 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 - +Function scenario_package(doc As String, ByRef errorMsg As String) As Object + Set scenario_package = makeHttpRequest("GET", "scenario_package", doc, errorMsg) End Function - Sub pg_main_workset(catg As String, rep 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 & """}}" - + Dim errorMsg As String 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 + + Dim json As Object + Set json = makeHttpRequest("GET", "get_pool", "{""scenario"":{""" & catg & """:""" & rep & """}}", errorMsg) - If Mid(wr, 1, 1) <> "{" Then - MsgBox (wr) - Exit Sub - End If - - Application.StatusBar = "Parsing query results..." - Set json = JsonConverter.ParseJson(wr) - - If IsNull(json("x")) Then - MsgBox "No data found for " & rep & "." + If errorMsg <> "" Then + MsgBox errorMsg, vbOKOnly + vbExclamation, "Couldn't " & rep & "'s pool of data." Exit Sub End If @@ -229,64 +172,18 @@ End Sub -Function request_adjust(doc As String, ByRef msg As String) As Boolean - - Dim req As New WinHttp.WinHttpRequest +Sub request_adjust(doc As String, ByRef errorMsg As String) 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) - 'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss") - 'doc = JsonConverter.ConvertToJson(doc) + Set json = makeHttpRequest("POST", json("type"), doc, errorMsg) - server = shConfig.Range("server").Value - - 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) = "" Or _ - Mid(wr, 1, 6) = " "" Then + Exit Sub End If ReDim res(json("x").Count - 1, 34) + Dim i As Long For i = 0 To UBound(res, 1) res(i, 0) = json("x")(i + 1)("bill_cust_descr") 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") Next i - request_adjust = True + errorMsg = "" i = shData.UsedRange.Rows.Count + 1 Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True) shOrders.PivotTables("ptOrders").PivotCache.Refresh -End Function +End Sub Sub load_config() @@ -481,44 +378,17 @@ Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant End Function -Function list_changes(doc As String, ByRef fail As Boolean) As Variant() - - Dim req As New WinHttp.WinHttpRequest +Function list_changes(doc As String, ByRef errorMsg As String) As Variant() Dim json As Object - Dim wr As String - Dim i As Long - Dim j As Long - Dim res() As Variant + Set json = makeHttpRequest("GET", "list_changes", doc, errorMsg) - 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 & "/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 + If errorMsg <> "" Then Exit Function End If ReDim res(json("x").Count - 1, 7) - + + Dim i As Long 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") @@ -534,39 +404,16 @@ Function list_changes(doc As String, ByRef fail As Boolean) As Variant() End Function -Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant() - - Dim req As New WinHttp.WinHttpRequest +Sub undo_changes(ByVal logid As Integer, ByRef errorMsg As String) Dim json As Object - Dim wr As String - Dim i As Long - Dim j As Long - Dim res() As Variant - Dim doc As String - Dim ds As Worksheet + Set json = makeHttpRequest("GET", "undo_change", "{""logid"":" & logid & "}", errorMsg) - 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") '---------loop through and get a list of each row that needs deleted?----- + Dim i As Long + Dim j As Long j = 0 For i = 1 To 100 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 If j = 0 Then - MsgBox ("Current data set is not tracking changes. Cannot isolate change locally.") - fail = True - Exit Function + errorMsg = "Current data set is not tracking changes. Cannot isolate change locally." + Exit Sub End If i = 2 @@ -592,54 +438,21 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant( Wend End With -End Function +End Sub Sub history() - changes.Show - End Sub -Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant() - - Dim req As New WinHttp.WinHttpRequest +Function get_swap_fit(doc As String, ByRef errorMsg As String) As Variant() Dim json As Object - Dim wr As String - Dim i As Integer - Dim j As Integer + Set json = makeHttpRequest("GET", "swap_fit", doc, errorMsg) + 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) + Dim i As Integer For i = 0 To UBound(res, 1) res(i, 0) = json("x")(i + 1)("part") res(i, 1) = json("x")(i + 1)("value_usd") diff --git a/Master Template.xlsm_EXPORTS/openf.frx b/Master Template.xlsm_EXPORTS/openf.frx index e539813..a52e5cf 100644 Binary files a/Master Template.xlsm_EXPORTS/openf.frx and b/Master Template.xlsm_EXPORTS/openf.frx differ diff --git a/Master Template.xlsm_EXPORTS/part.frx b/Master Template.xlsm_EXPORTS/part.frx index 736f979..1654ba9 100644 Binary files a/Master Template.xlsm_EXPORTS/part.frx and b/Master Template.xlsm_EXPORTS/part.frx differ diff --git a/Master Template.xlsm_EXPORTS/shMonthView.cls b/Master Template.xlsm_EXPORTS/shMonthView.cls index f8c58bd..14cdd11 100644 --- a/Master Template.xlsm_EXPORTS/shMonthView.cls +++ b/Master Template.xlsm_EXPORTS/shMonthView.cls @@ -727,8 +727,11 @@ Sub post_adjust() adjust("message") = shMonthView.Range("MonthComment").Value adjust("tag") = shMonthView.Range("MonthTag").Value 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 End If Else @@ -739,7 +742,8 @@ Sub post_adjust() adjust("message") = shMonthView.Range("MonthComment").Value adjust("tag") = shMonthView.Range("MonthTag").Value jdoc = JsonConverter.ConvertToJson(adjust) - If Not handler.request_adjust(jdoc, msg) Then + handler.request_adjust jdoc, errorMsg + If errorMsg <> "" Then Dim period As String period = Format(i - 1, "00") & " - " & Format(DateSerial(2000, (i - 1) + 5, 1), "mmm") allMsg = IIf(allMsg = "", "", vbNewLine) & period & ": " & msg @@ -804,7 +808,7 @@ Sub new_part() 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 - MsgBox ("Error building customer mix.") + MsgBox "Error building customer mix." End If '--------inquire for new part to join with cust mix--------------------------------------------