list history of changes

build.frm

@@ -28,7 +28,7 @@ Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift A
             useval = True
             Me.Hide
         Case 27
-            canel = False
+            useval = False
             Me.Hide
     End Select
 End Sub
@@ -75,3 +75,4 @@ Private Sub UserForm_Activate()
 End Sub
 
 
+

changes.frm

@@ -0,0 +1,53 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes 
+   Caption         =   "History"
+   ClientHeight    =   7740
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   16260
+   OleObjectBlob   =   "changes.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "changes"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private x As Variant
+
+Private Sub cbCancel_Click()
+
+    Me.Hide
+
+End Sub
+
+Private Sub lbHist_Change()
+
+    Dim i As Integer
+
+    For i = 0 To Me.lbHist.ListCount - 1
+        If Me.lbHist.Selected(i) Then
+            Me.tbPrint.value = x(i, 4)
+            Exit Sub
+        End If
+    Next i
+        
+    
+
+End Sub
+
+
+
+Private Sub UserForm_Activate()
+
+    Dim fail As Boolean
+    
+    x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail)
+    If fail Then
+        Me.Hide
+        Exit Sub
+    End If
+    Me.lbHist.list = x
+
+End Sub
+

fpvt.frm

@@ -1,10 +1,10 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt 
    Caption         =   "Forecast Adjustment"
-   ClientHeight    =   7590
+   ClientHeight    =   7350
    ClientLeft      =   120
    ClientTop       =   465
-   ClientWidth     =   7095
+   ClientWidth     =   7110
    OleObjectBlob   =   "fpvt.frx":0000
    StartUpPosition =   1  'CenterOwner
 End
@@ -147,6 +147,10 @@ Private Sub lbMonth_Change()
     
     
     
+End Sub
+
+Private Sub lheader_Click()
+
 End Sub
 
 Private Sub opEditPrice_Click()
@@ -301,10 +305,15 @@ Private Sub UserForm_Activate()
     Dim k As Long
     Dim ok As Boolean
     
+    Me.Caption = "Forecast Adjust " & Worksheets("config").Cells(8, 2)
     Me.mp.Visible = False
     
+    Me.lheader = "Loading..."
+
     Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
     
+    Me.lheader = "Ready"
+    
     If Not ok Then
         fpvt.Hide
         Application.StatusBar = False
@@ -327,6 +336,12 @@ Private Sub UserForm_Activate()
     fVol = 0
     fPrc = 0
     
+    If IsNull(sp("package")("totals")) Then
+        fpvt.Hide
+        Application.StatusBar = False
+        Exit Sub
+    End If
+    
     For i = 1 To sp("package")("totals").Count
         Select Case sp("package")("totals")(i)("order_season")
             Case 2020

handler.bas

@@ -203,8 +203,8 @@ 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 Integer
+    Dim i As Long
-    Dim j As Integer
+    Dim j As Long
     Dim str() As String
     
     If doc = "" Then
@@ -212,7 +212,11 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
         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
@@ -292,22 +296,25 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
 
     ReDim str(UBound(res, 1), UBound(res, 2))
     
-    For i = 0 To UBound(res, 1)
+'    For i = 0 To UBound(res, 1)
-        For j = 0 To UBound(res, 2)
+'        For j = 0 To UBound(res, 2)
-            If IsNull(res(i, j)) Then
+'            If IsNull(res(i, j)) Then
-                str(i, j) = ""
+'                str(i, j) = ""
-            Else
+'            Else
-                str(i, j) = res(i, j)
+'                str(i, j) = res(i, j)
-            End If
+'            End If
-        Next j
+'        Next j
-    Next i
+'    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)
+    
+    'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
     
     Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
     
@@ -468,3 +475,55 @@ 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
+    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, 5)
+    
+    For i = 0 To UBound(res, 1)
+        res(i, 0) = json("x")(i + 1)("user")
+        res(i, 1) = json("x")(i + 1)("stamp")
+        res(i, 2) = json("x")(i + 1)("comment")
+        res(i, 3) = json("x")(i + 1)("sales")
+        res(i, 4) = json("x")(i + 1)("def")
+    Next i
+    
+    list_changes = res
+
+End Function
+
+Sub history()
+
+    changes.Show
+
+End Sub

months.cls

@@ -800,7 +800,7 @@ Sub post_adjust()
     End If
     
     Sheets("Orders").Select
-    Worksheets("month").Visible = xlHidden
+    'Worksheets("month").Visible = xlHidden
 
 End Sub
 

pivot.cls

@@ -101,6 +101,7 @@ Function escape(ByVal text As String) As String
 
     text = Replace(text, "'", "''")
     text = Replace(text, """", """""")
+    If text = "(blank)" Then text = ""
     escape = text
 
 End Function