export VBA files for version 1.7 on teams
This commit is contained in:
parent
8809cb9ad4
commit
98ed8c52dc
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,247 @@
|
|||
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
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
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
|
||||
|
||||
|
||||
|
||||
Binary file not shown.
|
|
@ -0,0 +1,134 @@
|
|||
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
|
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
|
|
@ -0,0 +1,643 @@
|
|||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,51 @@
|
|||
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
|
||||
|
||||
Binary file not shown.
|
|
@ -0,0 +1,48 @@
|
|||
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
|
||||
|
||||
|
||||
Binary file not shown.
|
|
@ -0,0 +1,122 @@
|
|||
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
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,122 @@
|
|||
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