list history of changes

This commit is contained in:
Trowbridge 2019-03-22 18:18:23 -04:00
parent 1a09f55fb9
commit 830894ed5d
9 changed files with 145 additions and 16 deletions

View File

@ -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

BIN
build.frx

Binary file not shown.

53
changes.frm Normal file
View File

@ -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

BIN
changes.frx Normal file

Binary file not shown.

View File

@ -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

BIN
fpvt.frx

Binary file not shown.

View File

@ -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 j As Integer
Dim i As Long
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 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
' 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)
'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

View File

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

View File

@ -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