Compare commits
No commits in common. "2c63d400f7a3373f87815cedfae5d90c4169b843" and "8809cb9ad4a76b1aabe24551b7248f4319dcecb7" have entirely different histories.
2c63d400f7
...
8809cb9ad4
Binary file not shown.
File diff suppressed because it is too large
Load Diff
2730
VBA/TheBigOne.cls
2730
VBA/TheBigOne.cls
File diff suppressed because it is too large
Load Diff
@ -1,247 +0,0 @@
|
|||||||
VERSION 1.0 CLASS
|
|
||||||
BEGIN
|
|
||||||
MultiUse = -1 'True
|
|
||||||
END
|
|
||||||
Attribute VB_Name = "Windows_API"
|
|
||||||
Attribute VB_GlobalNameSpace = False
|
|
||||||
Attribute VB_Creatable = False
|
|
||||||
Attribute VB_PredeclaredId = False
|
|
||||||
Attribute VB_Exposed = False
|
|
||||||
Option Explicit
|
|
||||||
|
|
||||||
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
|
|
||||||
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
|
|
||||||
Private Declare PtrSafe Function GetClipboardOwner Lib "user32" () As LongPtr
|
|
||||||
Private Declare PtrSafe Function SetClipboardViewer Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GetClipboardViewer Lib "user32" () As LongPtr
|
|
||||||
Private Declare PtrSafe Function ChangeClipboardChain Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndNext As LongPtr) As Long
|
|
||||||
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
|
|
||||||
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
|
|
||||||
Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
|
|
||||||
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
|
|
||||||
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _
|
|
||||||
(ByVal wFormat As Long, _
|
|
||||||
ByVal lpString As String, _
|
|
||||||
ByVal nMaxCount As Long) As Long
|
|
||||||
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
|
|
||||||
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
|
|
||||||
Private Declare PtrSafe Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
|
|
||||||
Private Declare PtrSafe Function GetOpenClipboardWindow Lib "user32" () As LongPtr
|
|
||||||
Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" _
|
|
||||||
(ByVal lpszSrc As String, _
|
|
||||||
ByVal lpszDst As String) As Long
|
|
||||||
Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
|
|
||||||
Private Declare PtrSafe Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" _
|
|
||||||
(ByVal lpszSrc As String, _
|
|
||||||
ByVal lpszDst As String, _
|
|
||||||
ByVal cchDstLength As Long) As Long
|
|
||||||
Private Declare PtrSafe Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" _
|
|
||||||
(ByVal lpszSrc As String, _
|
|
||||||
ByVal lpszDst As String, _
|
|
||||||
ByVal cchDstLength As Long) As Long
|
|
||||||
Private Declare PtrSafe Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String
|
|
||||||
Private Declare PtrSafe Function CharUpperBuff Lib "user32" Alias "CharUpperBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
|
|
||||||
Private Declare PtrSafe Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String
|
|
||||||
Private Declare PtrSafe Function CharLowerBuff Lib "user32" Alias "CharLowerBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
|
|
||||||
Private Declare PtrSafe Function CharNext Lib "user32" Alias "CharNextA" (ByVal lpsz As String) As String
|
|
||||||
Private Declare PtrSafe Function CharPrev Lib "user32" Alias "CharPrevA" (ByVal lpszStart As String, ByVal lpszCurrent As String) As String
|
|
||||||
Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GlobalHandle Lib "kernel32" (wMem As Any) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GlobalReAlloc Lib "kernel32" (ByVal hMem As LongPtr, ByVal dwBytes As LongPtr, ByVal wFlags As Long) As LongPtr
|
|
||||||
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
|
|
||||||
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
|
|
||||||
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _
|
|
||||||
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
|
|
||||||
ByVal wMsgFilterMin As Long, _
|
|
||||||
ByVal wMsgFilterMax As Long, _
|
|
||||||
ByVal wRemoveMsg As Long) As Long
|
|
||||||
Private Declare PtrSafe Function TranslateMessage Lib "user32" _
|
|
||||||
(ByRef lpMsg As MSG) As Long
|
|
||||||
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
|
|
||||||
(ByVal hwnd As Long, _
|
|
||||||
ByVal wMsg As Long, _
|
|
||||||
ByVal wParam As Long, _
|
|
||||||
lParam As Any) As Long
|
|
||||||
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
|
|
||||||
(ByVal lpClassName As String, _
|
|
||||||
ByVal lpWindowName As String) As Long
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Private Type POINTAPI
|
|
||||||
x As Long
|
|
||||||
Y As Long
|
|
||||||
End Type
|
|
||||||
|
|
||||||
Private Type MSG
|
|
||||||
hwnd As Long
|
|
||||||
Message As Long
|
|
||||||
wParam As Long
|
|
||||||
lParam As Long
|
|
||||||
time As Long
|
|
||||||
pt As POINTAPI
|
|
||||||
End Type
|
|
||||||
|
|
||||||
Private Const WM_KEYDOWN As Long = &H100
|
|
||||||
Private Const PM_REMOVE As Long = &H1
|
|
||||||
Private Const WM_CHAR As Long = &H102
|
|
||||||
Private Const GHND As Long = &H42
|
|
||||||
Private Const CF_TEXT = 1
|
|
||||||
Private Const MAXSIZE = 40096
|
|
||||||
Private bExitLoop As Boolean
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Public Sub SetClipboard(sUniText As String)
|
|
||||||
Dim iStrPtr As LongPtr
|
|
||||||
Dim iLen As LongPtr
|
|
||||||
Dim iLock As LongPtr
|
|
||||||
Const GMEM_MOVEABLE As Long = &H2
|
|
||||||
Const GMEM_ZEROINIT As Long = &H40
|
|
||||||
Const CF_UNICODETEXT As Long = &HD
|
|
||||||
OpenClipboard 0&
|
|
||||||
EmptyClipboard
|
|
||||||
iLen = LenB(sUniText) + 2&
|
|
||||||
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
|
|
||||||
iLock = GlobalLock(iStrPtr)
|
|
||||||
lstrcpy iLock, StrPtr(sUniText)
|
|
||||||
GlobalUnlock iStrPtr
|
|
||||||
SetClipboardData CF_UNICODETEXT, iStrPtr
|
|
||||||
CloseClipboard
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Public Sub ClipBoard_SetData(sUniText As String)
|
|
||||||
|
|
||||||
|
|
||||||
Dim hGlobalMemory As LongPtr
|
|
||||||
Dim lpGlobalMemory As LongPtr
|
|
||||||
Dim hClipMemory As LongPtr
|
|
||||||
Dim x As Long
|
|
||||||
|
|
||||||
hGlobalMemory = GlobalAlloc(GHND, Len(sUniText) + 1)
|
|
||||||
|
|
||||||
lpGlobalMemory = GlobalLock(hGlobalMemory)
|
|
||||||
|
|
||||||
lpGlobalMemory = lstrcpy(lpGlobalMemory, sUniText)
|
|
||||||
|
|
||||||
If GlobalUnlock(hGlobalMemory) <> 0 Then
|
|
||||||
GoTo OutOfHere2
|
|
||||||
End If
|
|
||||||
|
|
||||||
If OpenClipboard(0&) = 0 Then
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
|
|
||||||
x = EmptyClipboard()
|
|
||||||
|
|
||||||
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
|
|
||||||
|
|
||||||
OutOfHere2:
|
|
||||||
|
|
||||||
If CloseClipboard() = 0 Then
|
|
||||||
MsgBox ("ruh-roh")
|
|
||||||
End If
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Public Function GetClipboard() As String
|
|
||||||
Dim iStrPtr As Long
|
|
||||||
Dim iLen As Long
|
|
||||||
Dim iLock As Long
|
|
||||||
Dim sUniText As String
|
|
||||||
Const CF_UNICODETEXT As Long = 13&
|
|
||||||
OpenClipboard 0&
|
|
||||||
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
|
|
||||||
iStrPtr = GetClipboardData(CF_UNICODETEXT)
|
|
||||||
If iStrPtr Then
|
|
||||||
iLock = GlobalLock(iStrPtr)
|
|
||||||
iLen = GlobalSize(iStrPtr)
|
|
||||||
sUniText = String$(iLen \ 2& - 1&, vbNullChar)
|
|
||||||
lstrcpy StrPtr(sUniText), iLock
|
|
||||||
GlobalUnlock iStrPtr
|
|
||||||
End If
|
|
||||||
GetClipboard = sUniText
|
|
||||||
End If
|
|
||||||
CloseClipboard
|
|
||||||
End Function
|
|
||||||
|
|
||||||
|
|
||||||
Sub TrackKeyPressInit()
|
|
||||||
|
|
||||||
Dim msgMessage As MSG
|
|
||||||
Dim bCancel As Boolean
|
|
||||||
Dim iKeyCode As Integer
|
|
||||||
Dim lXLhwnd As Long
|
|
||||||
|
|
||||||
On Error GoTo errHandler:
|
|
||||||
Application.EnableCancelKey = xlErrorHandler
|
|
||||||
'initialize this boolean flag.
|
|
||||||
bExitLoop = False
|
|
||||||
'get the app hwnd.
|
|
||||||
lXLhwnd = FindWindow("XLMAIN", Application.Caption)
|
|
||||||
Do
|
|
||||||
WaitMessage
|
|
||||||
'check for a key press and remove it from the msg queue.
|
|
||||||
If PeekMessage _
|
|
||||||
(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
|
|
||||||
'strore the virtual key code for later use.
|
|
||||||
iKeyCode = msgMessage.wParam
|
|
||||||
'translate the virtual key code into a char msg.
|
|
||||||
TranslateMessage msgMessage
|
|
||||||
PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
|
|
||||||
WM_CHAR, PM_REMOVE
|
|
||||||
'for some obscure reason, the following
|
|
||||||
'keys are not trapped inside the event handler
|
|
||||||
'so we handle them here.
|
|
||||||
If iKeyCode = vbKeyBack Then SendKeys "{BS}"
|
|
||||||
If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
|
|
||||||
'assume the cancel argument is False.
|
|
||||||
bCancel = False
|
|
||||||
'the VBA RaiseEvent statement does not seem to return ByRef arguments
|
|
||||||
'so we call a KeyPress routine rather than a propper event handler.
|
|
||||||
Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
|
|
||||||
'if the key pressed is allowed post it to the application.
|
|
||||||
If bCancel = False Then
|
|
||||||
PostMessage _
|
|
||||||
lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
|
|
||||||
End If
|
|
||||||
End If
|
|
||||||
errHandler:
|
|
||||||
'allow the processing of other msgs.
|
|
||||||
DoEvents
|
|
||||||
Loop Until bExitLoop
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Sub StopKeyWatch()
|
|
||||||
|
|
||||||
'set this boolean flag to exit the above loop.
|
|
||||||
bExitLoop = True
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
'\\This example illustrates how to catch worksheet
|
|
||||||
'\\Key strokes in order to prevent entering numeric
|
|
||||||
'\\characters in the Range "A1:D10" .
|
|
||||||
Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, ByVal Target As Range, Cancel As Boolean)
|
|
||||||
|
|
||||||
Const MSG As String = "Numeric Characters are not allowed in" & vbNewLine & "the Range: """
|
|
||||||
Const TITLE As String = "Invalid Entry !"
|
|
||||||
|
|
||||||
If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
|
|
||||||
If Chr(KeyAscii) Like "[0-9]" Then
|
|
||||||
MsgBox MSG & Range("A1:D10").address(False, False) _
|
|
||||||
& """ .", vbCritical, TITLE
|
|
||||||
Cancel = True
|
|
||||||
End If
|
|
||||||
End If
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,81 +0,0 @@
|
|||||||
VERSION 5.00
|
|
||||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build
|
|
||||||
Caption = "UserForm1"
|
|
||||||
ClientHeight = 3015
|
|
||||||
ClientLeft = 120
|
|
||||||
ClientTop = 465
|
|
||||||
ClientWidth = 8100
|
|
||||||
OleObjectBlob = "build.frx":0000
|
|
||||||
StartUpPosition = 1 'CenterOwner
|
|
||||||
End
|
|
||||||
Attribute VB_Name = "build"
|
|
||||||
Attribute VB_GlobalNameSpace = False
|
|
||||||
Attribute VB_Creatable = False
|
|
||||||
Attribute VB_PredeclaredId = True
|
|
||||||
Attribute VB_Exposed = False
|
|
||||||
Public part As String
|
|
||||||
Public bill As String
|
|
||||||
Public ship As String
|
|
||||||
Public useval As Boolean
|
|
||||||
Option Explicit
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
|
|
||||||
Select Case KeyCode
|
|
||||||
Case 13
|
|
||||||
useval = True
|
|
||||||
Me.Hide
|
|
||||||
Case 27
|
|
||||||
useval = False
|
|
||||||
Me.Hide
|
|
||||||
End Select
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
|
|
||||||
|
|
||||||
Select Case KeyCode
|
|
||||||
Case 13
|
|
||||||
useval = True
|
|
||||||
Me.Hide
|
|
||||||
Case 27
|
|
||||||
useval = False
|
|
||||||
Me.Hide
|
|
||||||
End Select
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub cbShip_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
|
|
||||||
Select Case KeyCode
|
|
||||||
Case 13
|
|
||||||
useval = True
|
|
||||||
Me.Hide
|
|
||||||
Case 27
|
|
||||||
useval = False
|
|
||||||
Me.Hide
|
|
||||||
End Select
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Private Sub UserForm_Activate()
|
|
||||||
|
|
||||||
useval = False
|
|
||||||
|
|
||||||
cbPart.value = part
|
|
||||||
cbBill.value = bill
|
|
||||||
cbShip.value = ship
|
|
||||||
|
|
||||||
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A2").CurrentRegion)
|
|
||||||
'cbPart.list(1).Remove
|
|
||||||
cbBill.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
|
|
||||||
'cbPart.list(1).Remove
|
|
||||||
cbShip.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
|
|
||||||
'cbPart.list(1).Remove
|
|
||||||
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
BIN
VBA/build.frx
BIN
VBA/build.frx
Binary file not shown.
134
VBA/changes.frm
134
VBA/changes.frm
@ -1,134 +0,0 @@
|
|||||||
VERSION 5.00
|
|
||||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes
|
|
||||||
Caption = "History"
|
|
||||||
ClientHeight = 7785
|
|
||||||
ClientLeft = 120
|
|
||||||
ClientTop = 465
|
|
||||||
ClientWidth = 16710
|
|
||||||
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 cbUndo_Click()
|
|
||||||
|
|
||||||
|
|
||||||
Call Me.delete_selected
|
|
||||||
|
|
||||||
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, 7)
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
Next i
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub lbHist_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
|
|
||||||
|
|
||||||
Select Case KeyCode
|
|
||||||
Case 46
|
|
||||||
Call Me.delete_selected
|
|
||||||
Case 27
|
|
||||||
Call Me.Hide
|
|
||||||
End Select
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub tbPrint_Change()
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub UserForm_Activate()
|
|
||||||
|
|
||||||
Dim fail As Boolean
|
|
||||||
|
|
||||||
'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail)
|
|
||||||
x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & Sheets("data").Cells(2, 5) & """}}", fail)
|
|
||||||
If fail Then
|
|
||||||
Me.Hide
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
Me.lbHist.list = x
|
|
||||||
|
|
||||||
lbHEAD.ColumnCount = lbHist.ColumnCount
|
|
||||||
lbHEAD.ColumnWidths = lbHist.ColumnWidths
|
|
||||||
|
|
||||||
' add header elements
|
|
||||||
lbHEAD.clear
|
|
||||||
lbHEAD.AddItem
|
|
||||||
lbHEAD.list(0, 0) = "Modifier"
|
|
||||||
lbHEAD.list(0, 1) = "Owner"
|
|
||||||
lbHEAD.list(0, 2) = "When"
|
|
||||||
lbHEAD.list(0, 3) = "Tag"
|
|
||||||
lbHEAD.list(0, 4) = "Comment"
|
|
||||||
lbHEAD.list(0, 5) = "Sales"
|
|
||||||
lbHEAD.list(0, 6) = "id"
|
|
||||||
Dim tbo As New TheBigOne
|
|
||||||
Call tbo.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
|
|
||||||
|
|
||||||
|
|
||||||
' make it pretty
|
|
||||||
'body.ZOrder (1)
|
|
||||||
'lbHEAD.ZOrder (0)
|
|
||||||
'lbHEAD.SpecialEffect = fmSpecialEffectFlat
|
|
||||||
'lbHEAD.BackColor = RGB(200, 200, 200)
|
|
||||||
'lbHEAD.Height = 10
|
|
||||||
|
|
||||||
' align header to body (should be done last!)
|
|
||||||
'lbHEAD.width = lbHist.width
|
|
||||||
'lbHEAD.Left = lbHist.Left
|
|
||||||
'lbHEAD.Top = lbHist.Top - (lbHEAD.Height - 1)
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Sub delete_selected()
|
|
||||||
|
|
||||||
Dim logid As Integer
|
|
||||||
Dim i As Integer
|
|
||||||
Dim fail As Boolean
|
|
||||||
Dim proceed As Boolean
|
|
||||||
|
|
||||||
If MsgBox("Permanently delete these changes?", vbOKCancel) = vbCancel Then
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
|
|
||||||
|
|
||||||
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")
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
End If
|
|
||||||
Next i
|
|
||||||
|
|
||||||
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
|
|
||||||
|
|
||||||
Me.lbHist.clear
|
|
||||||
Me.Hide
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
BIN
VBA/changes.frx
BIN
VBA/changes.frx
Binary file not shown.
1368
VBA/fpvt.frm
1368
VBA/fpvt.frm
File diff suppressed because it is too large
Load Diff
BIN
VBA/fpvt.frx
BIN
VBA/fpvt.frx
Binary file not shown.
643
VBA/handler.bas
643
VBA/handler.bas
@ -1,643 +0,0 @@
|
|||||||
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.lbSDET.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, 33)
|
|
||||||
|
|
||||||
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)("substance")
|
|
||||||
res(i, 8) = json("x")(i)("chan")
|
|
||||||
res(i, 9) = json("x")(i)("chansub")
|
|
||||||
res(i, 10) = json("x")(i)("part_descr")
|
|
||||||
res(i, 11) = json("x")(i)("part_group")
|
|
||||||
res(i, 12) = json("x")(i)("branding")
|
|
||||||
res(i, 13) = json("x")(i)("majg_descr")
|
|
||||||
res(i, 14) = json("x")(i)("ming_descr")
|
|
||||||
res(i, 15) = json("x")(i)("majs_descr")
|
|
||||||
res(i, 16) = json("x")(i)("mins_descr")
|
|
||||||
res(i, 17) = json("x")(i)("order_season")
|
|
||||||
res(i, 18) = json("x")(i)("order_month")
|
|
||||||
res(i, 19) = json("x")(i)("ship_season")
|
|
||||||
res(i, 20) = json("x")(i)("ship_month")
|
|
||||||
res(i, 21) = json("x")(i)("request_season")
|
|
||||||
res(i, 22) = json("x")(i)("request_month")
|
|
||||||
res(i, 23) = json("x")(i)("promo")
|
|
||||||
res(i, 24) = json("x")(i)("value_loc")
|
|
||||||
res(i, 25) = json("x")(i)("value_usd")
|
|
||||||
res(i, 26) = json("x")(i)("cost_loc")
|
|
||||||
res(i, 27) = json("x")(i)("cost_usd")
|
|
||||||
res(i, 28) = json("x")(i)("units")
|
|
||||||
res(i, 29) = json("x")(i)("version")
|
|
||||||
res(i, 30) = json("x")(i)("iter")
|
|
||||||
res(i, 31) = json("x")(i)("logid")
|
|
||||||
res(i, 32) = json("x")(i)("tag")
|
|
||||||
res(i, 33) = 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) = "substance"
|
|
||||||
res(0, 8) = "chan"
|
|
||||||
res(0, 9) = "chansub"
|
|
||||||
res(0, 10) = "part_descr"
|
|
||||||
res(0, 11) = "part_group"
|
|
||||||
res(0, 12) = "branding"
|
|
||||||
res(0, 13) = "majg_descr"
|
|
||||||
res(0, 14) = "ming_descr"
|
|
||||||
res(0, 15) = "majs_descr"
|
|
||||||
res(0, 16) = "mins_descr"
|
|
||||||
res(0, 17) = "order_season"
|
|
||||||
res(0, 18) = "order_month"
|
|
||||||
res(0, 19) = "ship_season"
|
|
||||||
res(0, 20) = "ship_month"
|
|
||||||
res(0, 21) = "request_season"
|
|
||||||
res(0, 22) = "request_month"
|
|
||||||
res(0, 23) = "promo"
|
|
||||||
res(0, 24) = "value_loc"
|
|
||||||
res(0, 25) = "value_usd"
|
|
||||||
res(0, 26) = "cost_loc"
|
|
||||||
res(0, 27) = "cost_usd"
|
|
||||||
res(0, 28) = "units"
|
|
||||||
res(0, 29) = "version"
|
|
||||||
res(0, 30) = "iter"
|
|
||||||
res(0, 31) = "logid"
|
|
||||||
res(0, 32) = "tag"
|
|
||||||
res(0, 33) = "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
|
|
||||||
|
|
||||||
If Mid(wr, 1, 6) = "null" Then
|
|
||||||
MsgBox ("API route not implemented")
|
|
||||||
fail = True
|
|
||||||
Exit Function
|
|
||||||
End If
|
|
||||||
|
|
||||||
Set json = JsonConverter.ParseJson(wr)
|
|
||||||
|
|
||||||
If IsNull(json("x")) Then
|
|
||||||
MsgBox ("no adjustment was made")
|
|
||||||
fail = False
|
|
||||||
Exit Function
|
|
||||||
End If
|
|
||||||
|
|
||||||
ReDim res(json("x").Count - 1, 33)
|
|
||||||
|
|
||||||
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")
|
|
||||||
res(i, 2) = json("x")(i + 1)("ship_cust_descr")
|
|
||||||
res(i, 3) = json("x")(i + 1)("shipto_group")
|
|
||||||
res(i, 4) = json("x")(i + 1)("quota_rep_descr")
|
|
||||||
res(i, 5) = json("x")(i + 1)("director")
|
|
||||||
res(i, 6) = json("x")(i + 1)("segm")
|
|
||||||
res(i, 7) = json("x")(i + 1)("substance")
|
|
||||||
res(i, 8) = json("x")(i + 1)("chan")
|
|
||||||
res(i, 9) = json("x")(i + 1)("chansub")
|
|
||||||
res(i, 10) = json("x")(i + 1)("part_descr")
|
|
||||||
res(i, 11) = json("x")(i + 1)("part_group")
|
|
||||||
res(i, 12) = json("x")(i + 1)("branding")
|
|
||||||
res(i, 13) = json("x")(i + 1)("majg_descr")
|
|
||||||
res(i, 14) = json("x")(i + 1)("ming_descr")
|
|
||||||
res(i, 15) = json("x")(i + 1)("majs_descr")
|
|
||||||
res(i, 16) = json("x")(i + 1)("mins_descr")
|
|
||||||
res(i, 17) = json("x")(i + 1)("order_season")
|
|
||||||
res(i, 18) = json("x")(i + 1)("order_month")
|
|
||||||
res(i, 19) = json("x")(i + 1)("ship_season")
|
|
||||||
res(i, 20) = json("x")(i + 1)("ship_month")
|
|
||||||
res(i, 21) = json("x")(i + 1)("request_season")
|
|
||||||
res(i, 22) = json("x")(i + 1)("request_month")
|
|
||||||
res(i, 23) = json("x")(i + 1)("promo")
|
|
||||||
res(i, 24) = json("x")(i + 1)("value_loc")
|
|
||||||
res(i, 25) = json("x")(i + 1)("value_usd")
|
|
||||||
res(i, 26) = json("x")(i + 1)("cost_loc")
|
|
||||||
res(i, 27) = json("x")(i + 1)("cost_usd")
|
|
||||||
res(i, 28) = json("x")(i + 1)("units")
|
|
||||||
res(i, 29) = json("x")(i + 1)("version")
|
|
||||||
res(i, 30) = json("x")(i + 1)("iter")
|
|
||||||
res(i, 31) = json("x")(i + 1)("logid")
|
|
||||||
res(i, 32) = json("x")(i + 1)("tag")
|
|
||||||
res(i, 33) = json("x")(i + 1)("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)("doc")
|
|
||||||
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
|
|
||||||
|
|
||||||
Function get_swap_fit(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 & "/swap_fit", 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, 3)
|
|
||||||
|
|
||||||
For i = 0 To UBound(res, 1)
|
|
||||||
res(i, 0) = json("x")(i + 1)("part")
|
|
||||||
res(i, 1) = json("x")(i + 1)("value_usd")
|
|
||||||
res(i, 2) = json("x")(i + 1)("swap")
|
|
||||||
res(i, 3) = json("x")(i + 1)("fit")
|
|
||||||
Next i
|
|
||||||
|
|
||||||
get_swap_fit = res
|
|
||||||
|
|
||||||
End Function
|
|
||||||
1043
VBA/months.cls
1043
VBA/months.cls
File diff suppressed because it is too large
Load Diff
@ -1,51 +0,0 @@
|
|||||||
VERSION 5.00
|
|
||||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf
|
|
||||||
Caption = "Open a Forecast"
|
|
||||||
ClientHeight = 2025
|
|
||||||
ClientLeft = 120
|
|
||||||
ClientTop = 465
|
|
||||||
ClientWidth = 3825
|
|
||||||
OleObjectBlob = "openf.frx":0000
|
|
||||||
StartUpPosition = 1 'CenterOwner
|
|
||||||
End
|
|
||||||
Attribute VB_Name = "openf"
|
|
||||||
Attribute VB_GlobalNameSpace = False
|
|
||||||
Attribute VB_Creatable = False
|
|
||||||
Attribute VB_PredeclaredId = True
|
|
||||||
Attribute VB_Exposed = False
|
|
||||||
Private Sub cbCancel_Click()
|
|
||||||
|
|
||||||
openf.Hide
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Private Sub cbOK_Click()
|
|
||||||
|
|
||||||
Application.StatusBar = "Retrieving data for " & cbDSM.value & "....."
|
|
||||||
|
|
||||||
openf.Caption = "retrieving data......"
|
|
||||||
Call handler.pg_main_workset(cbDSM.value)
|
|
||||||
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
|
|
||||||
Application.StatusBar = False
|
|
||||||
openf.Hide
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Private Sub UserForm_Activate()
|
|
||||||
|
|
||||||
'handler.server = "http://192.168.1.69:3000"
|
|
||||||
handler.server = Sheets("config").Cells(1, 2)
|
|
||||||
|
|
||||||
Dim x As New TheBigOne
|
|
||||||
Dim d() As String
|
|
||||||
|
|
||||||
openf.Caption = "Select a DSM"
|
|
||||||
d = x.SHTp_Get("reps", 1, 1, True)
|
|
||||||
|
|
||||||
For i = 1 To UBound(d, 2)
|
|
||||||
Call cbDSM.AddItem(d(0, i))
|
|
||||||
Next i
|
|
||||||
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
BIN
VBA/openf.frx
BIN
VBA/openf.frx
Binary file not shown.
48
VBA/part.frm
48
VBA/part.frm
@ -1,48 +0,0 @@
|
|||||||
VERSION 5.00
|
|
||||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part
|
|
||||||
Caption = "Part Picker"
|
|
||||||
ClientHeight = 1080
|
|
||||||
ClientLeft = 120
|
|
||||||
ClientTop = 465
|
|
||||||
ClientWidth = 8100
|
|
||||||
OleObjectBlob = "part.frx":0000
|
|
||||||
StartUpPosition = 1 'CenterOwner
|
|
||||||
End
|
|
||||||
Attribute VB_Name = "part"
|
|
||||||
Attribute VB_GlobalNameSpace = False
|
|
||||||
Attribute VB_Creatable = False
|
|
||||||
Attribute VB_PredeclaredId = True
|
|
||||||
Attribute VB_Exposed = False
|
|
||||||
|
|
||||||
Public part As String
|
|
||||||
Public bill As String
|
|
||||||
Public ship As String
|
|
||||||
Public useval As Boolean
|
|
||||||
Option Explicit
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
|
|
||||||
|
|
||||||
Select Case KeyCode
|
|
||||||
Case 13
|
|
||||||
useval = True
|
|
||||||
Me.Hide
|
|
||||||
Case 27
|
|
||||||
useval = False
|
|
||||||
Me.Hide
|
|
||||||
End Select
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Private Sub UserForm_Activate()
|
|
||||||
|
|
||||||
useval = False
|
|
||||||
|
|
||||||
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
|
|
||||||
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
BIN
VBA/part.frx
BIN
VBA/part.frx
Binary file not shown.
122
VBA/pivot.cls
122
VBA/pivot.cls
@ -1,122 +0,0 @@
|
|||||||
VERSION 1.0 CLASS
|
|
||||||
BEGIN
|
|
||||||
MultiUse = -1 'True
|
|
||||||
END
|
|
||||||
Attribute VB_Name = "pivot"
|
|
||||||
Attribute VB_GlobalNameSpace = False
|
|
||||||
Attribute VB_Creatable = False
|
|
||||||
Attribute VB_PredeclaredId = True
|
|
||||||
Attribute VB_Exposed = True
|
|
||||||
Option Explicit
|
|
||||||
|
|
||||||
Private Sub Worksheet_Activate()
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
|
|
||||||
|
|
||||||
If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
|
|
||||||
On Error GoTo nopiv
|
|
||||||
|
|
||||||
If Target.Cells.PivotTable Is Nothing Then
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
|
|
||||||
Cancel = True
|
|
||||||
|
|
||||||
Dim i As Long
|
|
||||||
Dim j As Long
|
|
||||||
Dim k As Long
|
|
||||||
|
|
||||||
Dim ri As PivotItemList
|
|
||||||
Dim ci As PivotItemList
|
|
||||||
Dim df As Object
|
|
||||||
Dim rd As Object
|
|
||||||
Dim cd As Object
|
|
||||||
Dim dd As Object
|
|
||||||
|
|
||||||
Dim pt As PivotTable
|
|
||||||
Dim pf As PivotField
|
|
||||||
Dim pi As PivotItem
|
|
||||||
Dim wapi As New Windows_API
|
|
||||||
|
|
||||||
Set ri = Target.Cells.PivotCell.RowItems
|
|
||||||
Set ci = Target.Cells.PivotCell.ColumnItems
|
|
||||||
Set df = Target.Cells.PivotCell.DataField
|
|
||||||
|
|
||||||
Set rd = Target.Cells.PivotTable.RowFields
|
|
||||||
Set cd = Target.Cells.PivotTable.ColumnFields
|
|
||||||
|
|
||||||
ReDim handler.sc(ri.Count, 1)
|
|
||||||
Set pt = Target.Cells.PivotCell.PivotTable
|
|
||||||
|
|
||||||
handler.sql = ""
|
|
||||||
handler.jsql = ""
|
|
||||||
|
|
||||||
For i = 1 To ri.Count
|
|
||||||
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
|
|
||||||
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
|
|
||||||
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
|
|
||||||
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
|
|
||||||
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
|
|
||||||
handler.sc(i - 1, 1) = ri(i).Name
|
|
||||||
Next i
|
|
||||||
|
|
||||||
scenario = "{" & handler.jsql & "}"
|
|
||||||
|
|
||||||
Call handler.load_config
|
|
||||||
Call handler.load_fpvt
|
|
||||||
|
|
||||||
nopiv:
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Function piv_pos(list As Object, target_pos As Long) As Long
|
|
||||||
|
|
||||||
Dim i As Long
|
|
||||||
|
|
||||||
For i = 1 To list.Count
|
|
||||||
If list(i).Position = target_pos Then
|
|
||||||
piv_pos = i
|
|
||||||
Exit Function
|
|
||||||
End If
|
|
||||||
Next i
|
|
||||||
'should not get to this point
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
|
|
||||||
|
|
||||||
Dim i As Integer
|
|
||||||
|
|
||||||
For i = 1 To pt.PivotFields.Count
|
|
||||||
If pt.PivotFields(i).Name = field_name Then
|
|
||||||
piv_fld_index = i
|
|
||||||
Exit Function
|
|
||||||
End If
|
|
||||||
Next i
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
Function escape_json(ByVal text As String) As String
|
|
||||||
|
|
||||||
text = Replace(text, "'", "''")
|
|
||||||
text = Replace(text, """", "\""")
|
|
||||||
If text = "(blank)" Then text = ""
|
|
||||||
escape_json = text
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
Function escape_sql(ByVal text As String) As String
|
|
||||||
|
|
||||||
text = Replace(text, "'", "''")
|
|
||||||
text = Replace(text, """", """""")
|
|
||||||
If text = "(blank)" Then text = ""
|
|
||||||
escape_sql = text
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
|
|
||||||
122
VBA/pivot1.cls
122
VBA/pivot1.cls
@ -1,122 +0,0 @@
|
|||||||
VERSION 1.0 CLASS
|
|
||||||
BEGIN
|
|
||||||
MultiUse = -1 'True
|
|
||||||
END
|
|
||||||
Attribute VB_Name = "pivot1"
|
|
||||||
Attribute VB_GlobalNameSpace = False
|
|
||||||
Attribute VB_Creatable = False
|
|
||||||
Attribute VB_PredeclaredId = True
|
|
||||||
Attribute VB_Exposed = True
|
|
||||||
Option Explicit
|
|
||||||
|
|
||||||
Private Sub Worksheet_Activate()
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
|
|
||||||
|
|
||||||
If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
|
|
||||||
On Error GoTo nopiv
|
|
||||||
|
|
||||||
If Target.Cells.PivotTable Is Nothing Then
|
|
||||||
Exit Sub
|
|
||||||
End If
|
|
||||||
|
|
||||||
Cancel = True
|
|
||||||
|
|
||||||
Dim i As Long
|
|
||||||
Dim j As Long
|
|
||||||
Dim k As Long
|
|
||||||
|
|
||||||
Dim ri As PivotItemList
|
|
||||||
Dim ci As PivotItemList
|
|
||||||
Dim df As Object
|
|
||||||
Dim rd As Object
|
|
||||||
Dim cd As Object
|
|
||||||
Dim dd As Object
|
|
||||||
|
|
||||||
Dim pt As PivotTable
|
|
||||||
Dim pf As PivotField
|
|
||||||
Dim pi As PivotItem
|
|
||||||
Dim wapi As New Windows_API
|
|
||||||
|
|
||||||
Set ri = Target.Cells.PivotCell.RowItems
|
|
||||||
Set ci = Target.Cells.PivotCell.ColumnItems
|
|
||||||
Set df = Target.Cells.PivotCell.DataField
|
|
||||||
|
|
||||||
Set rd = Target.Cells.PivotTable.RowFields
|
|
||||||
Set cd = Target.Cells.PivotTable.ColumnFields
|
|
||||||
|
|
||||||
ReDim handler.sc(ri.Count, 1)
|
|
||||||
Set pt = Target.Cells.PivotCell.PivotTable
|
|
||||||
|
|
||||||
handler.sql = ""
|
|
||||||
handler.jsql = ""
|
|
||||||
|
|
||||||
For i = 1 To ri.Count
|
|
||||||
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
|
|
||||||
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
|
|
||||||
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
|
|
||||||
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
|
|
||||||
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
|
|
||||||
handler.sc(i - 1, 1) = ri(i).Name
|
|
||||||
Next i
|
|
||||||
|
|
||||||
scenario = "{" & handler.jsql & "}"
|
|
||||||
|
|
||||||
Call handler.load_config
|
|
||||||
Call handler.load_fpvt
|
|
||||||
|
|
||||||
nopiv:
|
|
||||||
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
Function piv_pos(list As Object, target_pos As Long) As Long
|
|
||||||
|
|
||||||
Dim i As Long
|
|
||||||
|
|
||||||
For i = 1 To list.Count
|
|
||||||
If list(i).Position = target_pos Then
|
|
||||||
piv_pos = i
|
|
||||||
Exit Function
|
|
||||||
End If
|
|
||||||
Next i
|
|
||||||
'should not get to this point
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
|
|
||||||
|
|
||||||
Dim i As Integer
|
|
||||||
|
|
||||||
For i = 1 To pt.PivotFields.Count
|
|
||||||
If pt.PivotFields(i).Name = field_name Then
|
|
||||||
piv_fld_index = i
|
|
||||||
Exit Function
|
|
||||||
End If
|
|
||||||
Next i
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
Function escape_json(ByVal text As String) As String
|
|
||||||
|
|
||||||
text = Replace(text, "'", "''")
|
|
||||||
text = Replace(text, """", "\""")
|
|
||||||
If text = "(blank)" Then text = ""
|
|
||||||
escape_json = text
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
Function escape_sql(ByVal text As String) As String
|
|
||||||
|
|
||||||
text = Replace(text, "'", "''")
|
|
||||||
text = Replace(text, """", """""")
|
|
||||||
If text = "(blank)" Then text = ""
|
|
||||||
escape_sql = text
|
|
||||||
|
|
||||||
End Function
|
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue
Block a user