From 0e638bdd151b25eca560d459f6aa22c82d0f63d6 Mon Sep 17 00:00:00 2001 From: zhi Date: Tue, 18 Aug 2026 00:39:40 +0800 Subject: [PATCH] =?UTF-8?q?=E5=8A=A0=E5=85=A5=20CodeStore=20VBA=20?= =?UTF-8?q?=E6=A8=A1=E7=B5=84?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- CodeStore/index.xlsm_Module1.bas | 198 +++ CodeStore/index.xlsm_MyRibbon.bas | 157 ++ CodeStore/index.xlsm_ProgressDialogue.bas | 101 ++ CodeStore/index.xlsm_StringBuilder.bas | 46 + CodeStore/index.xlsm_ThisWorkbook.bas | 7 + CodeStore/index.xlsm_clsConcat.bas | 334 ++++ CodeStore/index.xlsm_stdArray.bas | 870 ++++++++++ CodeStore/index.xlsm_stdICallable.bas | 34 + CodeStore/index.xlsm_stdLambda.bas | 1817 +++++++++++++++++++++ CodeStore/index.xlsm_工作表1.bas | 56 + CodeStore/index.xlsm_工作表10.bas | 78 + CodeStore/index.xlsm_工作表11.bas | 265 +++ CodeStore/index.xlsm_工作表14.bas | 71 + CodeStore/index.xlsm_工作表15.bas | 2 + CodeStore/index.xlsm_工作表2.bas | 2 + CodeStore/index.xlsm_工作表3.bas | 2 + CodeStore/index.xlsm_工作表4.bas | 99 ++ CodeStore/index.xlsm_工作表5.bas | 2 + CodeStore/index.xlsm_工作表6.bas | 2 + CodeStore/index.xlsm_工作表7.bas | 83 + CodeStore/index.xlsm_工作表8.bas | 207 +++ CodeStore/index.xlsm_工作表9.bas | 77 + 22 files changed, 4510 insertions(+) create mode 100644 CodeStore/index.xlsm_Module1.bas create mode 100644 CodeStore/index.xlsm_MyRibbon.bas create mode 100644 CodeStore/index.xlsm_ProgressDialogue.bas create mode 100644 CodeStore/index.xlsm_StringBuilder.bas create mode 100644 CodeStore/index.xlsm_ThisWorkbook.bas create mode 100644 CodeStore/index.xlsm_clsConcat.bas create mode 100644 CodeStore/index.xlsm_stdArray.bas create mode 100644 CodeStore/index.xlsm_stdICallable.bas create mode 100644 CodeStore/index.xlsm_stdLambda.bas create mode 100644 CodeStore/index.xlsm_工作表1.bas create mode 100644 CodeStore/index.xlsm_工作表10.bas create mode 100644 CodeStore/index.xlsm_工作表11.bas create mode 100644 CodeStore/index.xlsm_工作表14.bas create mode 100644 CodeStore/index.xlsm_工作表15.bas create mode 100644 CodeStore/index.xlsm_工作表2.bas create mode 100644 CodeStore/index.xlsm_工作表3.bas create mode 100644 CodeStore/index.xlsm_工作表4.bas create mode 100644 CodeStore/index.xlsm_工作表5.bas create mode 100644 CodeStore/index.xlsm_工作表6.bas create mode 100644 CodeStore/index.xlsm_工作表7.bas create mode 100644 CodeStore/index.xlsm_工作表8.bas create mode 100644 CodeStore/index.xlsm_工作表9.bas diff --git a/CodeStore/index.xlsm_Module1.bas b/CodeStore/index.xlsm_Module1.bas new file mode 100644 index 0000000..7fa38c4 --- /dev/null +++ b/CodeStore/index.xlsm_Module1.bas @@ -0,0 +1,198 @@ +Attribute VB_Name = "Module1" +'**************** MySQLÅÜ¼Æ ****************** +Const server_name = "ms1.tc-clothing.com" ' ¦øªA¾¹IP¡A127.0.0.1¬°¥Ø«e¥»¾÷ +Const database_name = "clothing" ' ³s½u¸ê®Æ®w¦WºÙ +Const user_id = "clothing" ' ¸ê®Æ®wµn¤J±b¸¹ +Const UPassword = "clo256" ' ¸ê®Æ®wµn¤J±K½X +'******************************************** +Public PYEAR As Integer +Public PCOMPANY As Integer +Public XLSfile As String + + +Public Function Cnmyopen() As ADODB.Connection +Dim conn As New ADODB.Connection +Dim connStr As String '¸ê®Æ®w³s½u¦r¦ê¡A¨ä¤¤5.3¬°ODBCÅX°Êµ{¦¡ª©¥»¡A­n°t¦X§A¦w¸ËªºÅX°Ê¡C + connStr = "DRIVER={MariaDB ODBC 3.2 Driver}" _ + & ";SERVER=" & server_name _ + & ";DATABASE=" & database_name _ + & ";UID=" & user_id _ + & ";PWD=" & UPassword + conn.Open connStr +Set Cnmyopen = conn +' ¶Ç¦^Connection +End Function + +Public Function Cnxnopen(strSQL As String, v_imex As String) As ADODB.Connection +' strSQL ¼g¤JÀÉ®× v_imex 1=°ßŪ 0=¼g¤J +Dim conn As New ADODB.Connection +Dim connStr As String '¸ê®Æ®w³s½u¦r¦ê + connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Excel.ThisWorkbook.path & _ + strSQL & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=" & v_imex & ";"";" + conn.Open connStr +Set Cnxnopen = conn +' ¶Ç¦^Connection +End Function + +Public Function rstCnxnopen(strXLSfile As String, strSQL As String) As ADODB.Recordset +' ¶}±ÒExcelªí +Dim Cnxn As ADODB.Connection +Dim rstXLS As New ADODB.Recordset +Set Cnxn = Cnxnopen(strXLSfile, "1") + rstXLS.Open strSQL, Cnxn, adOpenStatic, adLockOptimistic, adCmdText +Set rstCnxnopen = rstXLS +' ¶Ç¦^Recordset +End Function + +Public Function rstCnmyopen(Cnmy As ADODB.Connection, strSQL As String) As ADODB.Recordset +' ¶}±ÒMysqlªí +Dim rstSQL As ADODB.Recordset +Set rstSQL = New ADODB.Recordset + rstSQL.CursorLocation = 3 'mysql RecordCount³s½uBUG by ÂŦâ¤pçE ¦Ñ¹xµ£ + rstSQL.Open strSQL, Cnmy +Set rstCnmyopen = rstSQL +' ¶Ç¦^Recordset +End Function + +Public Function sqlCnxnexec(strXLSfile As String, strSQL As String) +' °õ¦æSQL +Dim cn As New ADODB.Connection +' Dim Cnxn As ADODB.Connection +' Set Cnxn = Cnxnopen(strXLSfile, "1") +cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ + "Data Source=" & Excel.ThisWorkbook.path & strXLSfile & ";" & _ + "Extended Properties=""Excel 8.0;HDR=YES;IMEX=0""" +cn.Execute strSQL + +End Function + +Public Sub truncate_data(Cnmy As ADODB.Connection, SQLYear As Variant, SQLCompany As Variant) +' SQLYear ¦~«× SQLCompany ¤½¥q¥N½X +Dim strSQL As String + strSQL = "delete FROM CUSTOMER where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999;" + ' debug.print strSQL + Cnmy.Execute strSQL '§R°£¦W¥U + strSQL = "delete FROM SELLUP where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999;" + ' debug.print strSQL + Cnmy.Execute strSQL '§R°£ÁʶR +' ²M°£Â¸ê®Æ +End Sub + +Public Sub insert_data(Cnmy As ADODB.Connection, rstTBL As ADODB.Recordset, SQLYear As Variant, SQLCompany As Variant) +' ¶×¤J¦W¥U¸ê®Æ ¶q¨­¤Ø¤o +' rstTBL ExcelÀÉ®× SQLYear ¦~«× SQLCompany ¤½¥q +Dim sb As StringBuilder +Set sb = New StringBuilder +'====================================+ +Dim p As Long '+ +Dim diag As New ProgressDialogue '+ +'====================================+ +' «Ø¥ß¥¿³Wªí¥ÜªkÅÜ¼Æ +Dim Regex As New RegExp +'===================================================================================+ +p = 0 '+ +diag.Configure "§ó·s¸ê®Æ®É¶¡", "Now wasting your time...", 0, rstTBL.RecordCount '+ +diag.Show '+ +'===================================================================================+ + sb.Append "INSERT INTO CUSTOMER(id,regdate,company,department,seat,cus_no,cus_name,cus_sex,chest,waist,hip,leg,height,weight,trousers,tailor) VALUES " + While Not rstTBL.EOF + With rstTBL.Fields + If Not IsNull(.item("c_name")) Then + sb.Append "(" & .item("ID") & "," 'Field id + sb.Append "'" & .item("regdate") & "'," 'Field regdate + sb.Append "" & .item("company") & "," 'Field company + sb.Append "" & .item("depart") & "," 'Field department + sb.Append "" & .item("seat") & "," 'Field seat + sb.Append "'" & .item("cus_no") & "'," 'Field cus_no + ' ³]©w¤Ç°t³W«h + Regex.Pattern = "[^\u4E00-\u9FA5\u3000-\u303F\uFF00-\uFFEF\u0000-\u007F\u201c-\u201d]" + If Regex.test(.item("c_name")) Then Debug.Print .item("ID") + sb.Append "'" & .item("c_name") & "'," 'Field cus_name + sb.Append "" & .item("sex") & "," 'Field cus_sex + sb.Append "" & .item("chest") & "," 'Field chest + sb.Append "" & .item("waist") & "," 'Field waist + sb.Append "" & .item("hip") & "," 'Field hip + sb.Append "" & .item("leg") & "," 'Field leg + sb.Append "" & .item("height") & "," 'Field height + sb.Append "" & .item("weight") & "," 'Field weight + sb.Append "" & .item("trousers") & "," 'Field trousers + sb.Append "" & .item("tailor") & ")" 'Field tailor + End If + End With + rstTBL.MoveNext + If Not rstTBL.EOF Then sb.Append "," +'================================================+ +diag.SetValue p '+ +diag.SetStatus "Now wasting your time... " & p '+ +p = p + 1 '+ +'================================================+ + Wend + ' strSQL = Left(strSQL, Len(strSQL) - 1) +' Debug.Print sb.tostring + Cnmy.Execute sb.ToString +'============+ +diag.Hide '+ +'============+ +'§ó·sªA¸Ë¤Ø½X + ' Application.Calculation = xlAutomatic ' ³]¸m¦Û°Ê­«ºâ + ' MsgBox "§ó·s§¹¦¨¡I" +End Sub + +Public Sub insert_data2(Cnmy As ADODB.Connection, rstXLS As ADODB.Recordset, SQLYear As Variant, SQLCompany As Variant) +' ·s¼W¸ê®Æ¬q2 ªA¸Ë¤Ø½X +Dim sb As StringBuilder +Set sb = New StringBuilder +Dim rstGoodsUse As New ADODB.Recordset +' Debug.Print rstXLS!itsz1,rstXLS!item1 + strSQL = "Select pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure" & _ + " FROM GoodsUse" & _ + " WHERE corp_use=" & SQLCompany & _ + " and Depart_Use=(select department from CUSTOMER" & _ + " where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999" & _ + " limit 1)order by pno" + rstGoodsUse.CursorLocation = 3 'mysql RecordCount³s½uBUG by ÂŦâ¤pçE ¦Ñ¹xµ£ + rstGoodsUse.Open strSQL, Cnmy +' Debug.Print rstGoodsUse.RecordCount + ItCount = rstGoodsUse.RecordCount '³B²z¶µ¥Ø¼Æ + sb.Append "insert into SELLUP(id" + For i = 1 To ItCount + sb.Append "," & "itsz" & i & ",item" & i + Next i + sb.Append ") VALUES " + '¸ê®Æ¨Ó·½°ÊºA³]©w + While Not rstXLS.EOF + sb.Append "(" & rstXLS!ID & "," + rstGoodsUse.MoveFirst + i = 1 + While Not rstGoodsUse.EOF + sb.Append "goodsid('" & rstXLS.Fields.item("itsz" & i) & "'," & IIf(rstXLS!sex, rstGoodsUse!mtmodel, rstGoodsUse!wtmodel) & ")," & _ + rstXLS.Fields.item("item" & i) + i = i + 1 + rstGoodsUse.MoveNext + If Not rstGoodsUse.EOF Then sb.Append "," + Wend + sb.Append ")" + rstXLS.MoveNext + If Not rstXLS.EOF Then sb.Append "," + Wend + sb.Append ";" +' Debug.Print sb.tostring + Cnmy.Execute sb.ToString +rstGoodsUse.Close +' §¹¦¨¸ê®Æ·s¼W +End Sub + +Public Sub XLS_init() +' debug.print Worksheets("°â»ù").Cells(3, 11) + PYEAR = Worksheets("°â»ù").Cells(3, 11) +' debug.print Worksheets("°â»ù").Cells(5, 11) + PCOMPANY = Worksheets("°â»ù").Cells(5, 11) +' debug.print Worksheets("°â»ù").Cells(7, 11) + XLSfile = Worksheets("°â»ù").Cells(7, 11) +End Sub + + + + + + diff --git a/CodeStore/index.xlsm_MyRibbon.bas b/CodeStore/index.xlsm_MyRibbon.bas new file mode 100644 index 0000000..9f38a9f --- /dev/null +++ b/CodeStore/index.xlsm_MyRibbon.bas @@ -0,0 +1,157 @@ +Attribute VB_Name = "MyRibbon" + +'namespace=vba-files/ribbons + +'/* +'[Ribbon Menu Action] +'Ribbon Buttom 1 example call code +' +'*/ +Public Sub btn1(ByRef control As Office.IRibbonControl) + On Error GoTo ErrorHandler + + Dim wb1 As Workbook, wb2 As Workbook + Dim ws1 As Worksheet, ws2 As Worksheet + Dim PYEAR As String, PCOMPANY As String, XLSfile As String + Dim TM As Double, xRow As Long + + ' ªì©l¤ÆÅÜ¼Æ + InitializeVariables PYEAR, PCOMPANY, XLSfile + + ' ¥´¶}¤u§@ï + Set wb1 = OpenWorkbook(Excel.ThisWorkbook.path & "\..\..\¨îªA©ú²Ó.xlsx") + Set wb2 = OpenWorkbook(Excel.ThisWorkbook.path & XLSfile) + + ' ³]¸m¤u§@ªí + Set ws1 = wb1.Sheets("Sheet1") + Set ws2 = wb2.Sheets("¦W¥U") + + ' °õ¦æ¥D­n¾Þ§@ + TM = Timer + xRow = 10000 + ProcessData ws1, ws2, xRow + + ' Åã¥Ü°õ¦æ®É¶¡ + ws2.Range("AL1").value = Timer - TM + + ' Ãö³¬¤u§@ï + wb1.Close SaveChanges:=False + wb2.Close SaveChanges:=True + + Exit Sub + +ErrorHandler: + MsgBox "µo¥Í¿ù»~: " & Err.Description, vbCritical + On Error Resume Next + If Not wb1 Is Nothing Then wb1.Close SaveChanges:=False + If Not wb2 Is Nothing Then wb2.Close SaveChanges:=False +End Sub + +Private Sub InitializeVariables(ByRef PYEAR As String, ByRef PCOMPANY As String, ByRef XLSfile As String) + With ThisWorkbook.Worksheets("°â»ù") + PYEAR = .Cells(3, 11).value + PCOMPANY = .Cells(5, 11).value + XLSfile = .Cells(7, 11).value + End With +End Sub + +Private Function OpenWorkbook(ByVal path As String) As Workbook + Set OpenWorkbook = Workbooks.Open(path) +End Function + +Private Sub ProcessData(ByRef ws1 As Worksheet, ByRef ws2 As Worksheet, ByVal xRow As Long) + Dim arr As Variant, Brr As Variant, Crr As Variant + Dim xD As Object + Dim i As Long + + ' ²M°£ÂÂ¼Æ¾Ú + ws2.Columns("AK:AK").Clear + ws2.Range("AL1").value = "" + + ' Àò¨ú¼Æ¾Ú + arr = ws2.Range("F1").Resize(xRow) + Brr = ws1.Range("A1:F1").Resize(xRow) + Crr = Range("idx¯Z¥N½X").Resize(xRow) + + ' ³Ð«Ø¦r¨å¨Ã¶ñ¥R¼Æ¾Ú + Set xD = CreateObject("Scripting.Dictionary") + FillDictionary xD, Crr, Brr + + ' §ó·s Arr ¼Æ¾Ú + For i = 1 To UBound(arr) + If xD.Exists(arr(i, 1)) Then + arr(i, 1) = xD(arr(i, 1)) + End If + Next i + + ' ±Nµ²ªG¼g¦^¤u§@ªí + ws2.Range("AK1").Resize(xRow) = arr +End Sub + +Private Sub FillDictionary(ByRef xD As Object, ByRef Crr As Variant, ByRef Brr As Variant) + Dim i As Long + + For i = 1 To UBound(Crr) + If Not IsEmpty(Crr(i, 1)) Then xD(Crr(i, 1)) = Crr(i, 2) + Next i + + For i = 1 To UBound(Brr) + If Not IsEmpty(Brr(i, 6)) Then xD(Brr(i, 6)) = Brr(i, 4) + Next i +End Sub + +'/* +'[Ribbon Menu Action] +'Ribbon Buttom 2 example call code +' +'*/ +Public Sub btn2(ByRef control As Office.IRibbonControl) +' PYEAR ¦~«× PCOMPANY ¤½¥q¥N½X XLSfile ¦P¨BÀÉ®× +Dim Cnmy As ADODB.Connection +Dim rstXLS As New ADODB.Recordset +Dim strSQL As String +Set Cnmy = Cnmyopen() + PYEAR = Worksheets("°â»ù").Cells(3, 11) + PCOMPANY = Worksheets("°â»ù").Cells(5, 11) + XLSfile = Worksheets("°â»ù").Cells(7, 11) +Call truncate_data(Cnmy, PYEAR, PCOMPANY) + strSQL = "Select " & PYEAR & PCOMPANY & " & Format([½s¸¹],'0000') AS ID,Format(date(), 'yyyy-mm-dd') as regdate, company,[½s¸¹] as studentid,[¯ZID] as depart,[®y¸¹] as seat,[©m¦W] as c_name, IIf([©Ê§O]='¨k','true','false') AS sex" _ + & ",[¯Ý] as chest, [¸y] as waist,[Áv] as hip, [ªø] as leg,[¨­] as height,[­«] as weight, [¿Çªø] as trousers" _ + & ",[¾Ç¸¹] as cus_no,IIf([¿ï¨ú]='a','true','false') as tailor" _ + & " FROM [±b°È$] order by [½s¸¹];" +' Debug.Print strSQL +Set rstXLS = rstCnxnopen(XLSfile, strSQL) +Call insert_data(Cnmy, rstXLS, PYEAR, PCOMPANY) +rstXLS.Close + strSQL = "Select " & PYEAR & PCOMPANY & " & Format([½s¸¹],'0000') AS ID,IIf([©Ê§O]='¨k',true,false) AS sex" & _ + ", [®Õµu¤Ø½X] as itsz1, [®Õµu­qÁÊ] as item1, [®Õªø¤Ø½X] as itsz2, [®Õªø­qÁÊ] as item2" & _ + ", [®Õ®L¤Ø½X] as itsz3, [®Õ®L­qÁÊ] as item3, [®Õ¥V¤Ø½X] as itsz4, [®Õ¥V­qÁÊ] as item4, [®Õ¸È¤Ø½X] as itsz5, [®Õ¸È­qÁÊ] as item5" & _ + ", [­I¤ß¤Ø½X] as itsz6, [­I¤ß­qÁÊ] as item6, 'A' as itsz7, [»â±a­qÁÊ] as item7, 'A' as itsz8, [¸y±a­qÁÊ] as item8" & _ + ", 'A' as itsz9, [®Ñ¥]­qÁÊ] as item9" & _ + " FROM [±b°È$];" +' Debug.Print strSQL +Set rstXLS = rstCnxnopen(XLSfile, strSQL) +Call insert_data2(Cnmy, rstXLS, PYEAR, PCOMPANY) +rstXLS.Close +Cnmy.Close +' °õ¦æSQL¤W¶Ç +End Sub + + +'/* +'[Ribbon Menu Action] +'Ribbon Buttom 2 example call code +' +'*/ +Public Sub btn3(ByRef control As Office.IRibbonControl) + + PYEAR = Worksheets("°â»ù").Cells(3, 11) + PCOMPANY = Worksheets("°â»ù").Cells(5, 11) + XLSfile = Worksheets("°â»ù").Cells(7, 11) + +End Sub + + + + + diff --git a/CodeStore/index.xlsm_ProgressDialogue.bas b/CodeStore/index.xlsm_ProgressDialogue.bas new file mode 100644 index 0000000..8a2e8fc --- /dev/null +++ b/CodeStore/index.xlsm_ProgressDialogue.bas @@ -0,0 +1,101 @@ +Attribute VB_Name = "ProgressDialogue" +Option Explicit + +Dim Cancelled As Boolean, showTime As Boolean, showTimeLeft As Boolean +Dim startTime As Long +Dim BarMin As Long, BarMax As Long, BarVal As Long + +Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As Long + +'Title will be the title of the dialogue. +'Status will be the label above the progress bar, and can be changed with SetStatus. +'Min is the progress bar minimum value, only set by calling configure. +'Max is the progress bar maximum value, only set by calling configure. +'CancelButtonText is the caption of the cancel button. If set to vbNullString, it is hidden. +'optShowTimeElapsed controls whether the progress bar computes and displays the time elapsed. +'optShowTimeRemaining controls whether the progress bar estimates and displays the time remaining. +'calling Configure sets the current value equal to Min. +'calling Configure resets the current run time. +Public Sub Configure(ByVal title As String, ByVal status As String, _ + ByVal Min As Long, ByVal Max As Long, _ + Optional ByVal CancelButtonText As String = "Cancel", _ + Optional ByVal optShowTimeElapsed As Boolean = True, _ + Optional ByVal optShowTimeRemaining As Boolean = True) + Me.Caption = title + lblStatus.Caption = status + BarMin = Min + BarMax = Max + BarVal = Min + CancelButton.Visible = Not CancelButtonText = vbNullString + CancelButton.Caption = CancelButtonText + startTime = GetTickCount + showTime = optShowTimeElapsed + showTimeLeft = optShowTimeRemaining + lblRunTime.Caption = "" + lblRemainingTime.Caption = "" + Cancelled = False +End Sub + +'Set the label text above the status bar +Public Sub SetStatus(ByVal status As String) + lblStatus.Caption = status + DoEvents +End Sub + +'Set the value of the status bar, a long which is snapped to a value between Min and Max +Public Sub SetValue(ByVal value As Long) + If value < BarMin Then value = BarMin + If value > BarMax Then value = BarMax + Dim progress As Double, runTime As Long + BarVal = value + progress = (BarVal - BarMin) / (BarMax - BarMin) + ProgressBar.Width = 292 * progress + lblPercent = Int(progress * 10000) / 100 & "%" + runTime = GetRunTime() + If showTime Then lblRunTime.Caption = "Time Elapsed: " & GetRunTimeString(runTime, True) + If showTimeLeft And progress > 0 Then _ + lblRemainingTime.Caption = "Est. Time Left: " & GetRunTimeString(runTime * (1 - progress) / progress, False) + DoEvents +End Sub + +'Get the time (in milliseconds) since the progress bar "Configure" routine was last called +Public Function GetRunTime() As Long + GetRunTime = GetTickCount - startTime +End Function + +'Get the time (in hours, minutes, seconds) since "Configure" was last called +Public Function GetFormattedRunTime() As String + GetFormattedRunTime = GetRunTimeString(GetTickCount - startTime) +End Function + +'Formats a time in milliseconds as hours, minutes, seconds.milliseconds +'Milliseconds are excluded if showMsecs is set to false +Private Function GetRunTimeString(ByVal runTime As Long, Optional ByVal showMsecs As Boolean = True) As String + Dim msecs&, hrs&, mins&, secs# + msecs = runTime + hrs = Int(msecs / 3600000) + mins = Int(msecs / 60000) - 60 * hrs + secs = msecs / 1000 - 60 * (mins + 60 * hrs) + GetRunTimeString = IIf(hrs > 0, hrs & " hours ", "") _ + & IIf(mins > 0, mins & " minutes ", "") _ + & IIf(secs > 0, IIf(showMsecs, secs, Int(secs + 0.5)) & " seconds", "") +End Function + +'Returns the current value of the progress bar +Public Function GetValue() As Long + GetValue = BarVal +End Function + +'Returns whether or not the cancel button has been pressed. +'The ProgressDialogue must be polled regularily to detect whether cancel was pressed. +Public Function cancelIsPressed() As Boolean + cancelIsPressed = Cancelled +End Function + +'Recalls that cancel was pressed so that they calling routine can be notified next time it asks. +Private Sub CancelButton_Click() + Cancelled = True + lblStatus.Caption = "Cancelled By User. Please Wait." +End Sub + + diff --git a/CodeStore/index.xlsm_StringBuilder.bas b/CodeStore/index.xlsm_StringBuilder.bas new file mode 100644 index 0000000..3e4c97e --- /dev/null +++ b/CodeStore/index.xlsm_StringBuilder.bas @@ -0,0 +1,46 @@ +Attribute VB_Name = "StringBuilder" +Option Compare Text +Option Explicit + +Dim MyBuffer() As String +Dim MyCurrentIndex As Long +Dim MyMaxIndex As Long + +Private Sub Class_Initialize() + + Clear + +End Sub + +Public Sub Clear() + MyCurrentIndex = 0 + MyMaxIndex = 16 + ReDim MyBuffer(1 To MyMaxIndex) +End Sub + +'Appends the given Text to this StringBuilder +Public Sub Append(Text As String) + + MyCurrentIndex = MyCurrentIndex + 1 + + If MyCurrentIndex > MyMaxIndex Then + MyMaxIndex = 2 * MyMaxIndex + ReDim Preserve MyBuffer(1 To MyMaxIndex) + End If + MyBuffer(MyCurrentIndex) = Text + +End Sub + +'Returns the text in this StringBuilder +'Optional Parameter: Separator (default vbNullString) used in joining components +Public Function ToString(Optional Separator As String = vbNullString) As String + + If MyCurrentIndex > 0 Then + ReDim Preserve MyBuffer(1 To MyCurrentIndex) + MyMaxIndex = MyCurrentIndex + ToString = Join(MyBuffer, Separator) + End If + +End Function + + diff --git a/CodeStore/index.xlsm_ThisWorkbook.bas b/CodeStore/index.xlsm_ThisWorkbook.bas new file mode 100644 index 0000000..7e292cf --- /dev/null +++ b/CodeStore/index.xlsm_ThisWorkbook.bas @@ -0,0 +1,7 @@ +Attribute VB_Name = "ThisWorkbook" +Private Sub Workbook_Open() +' ¦Û°Ê°õ¦æ + Call XLS_init + Application.Caption = PYEAR & Worksheets("°â»ù").Cells(3, 1) +End Sub + diff --git a/CodeStore/index.xlsm_clsConcat.bas b/CodeStore/index.xlsm_clsConcat.bas new file mode 100644 index 0000000..c81c797 --- /dev/null +++ b/CodeStore/index.xlsm_clsConcat.bas @@ -0,0 +1,334 @@ +Attribute VB_Name = "clsConcat" +Option Compare Binary +Option Explicit + +' String concatenation (joining strings together) can have a significant +' performance impact when you are using the ampersand character to join +' strings together. While negligible in occasional use, if you start +' running tens of thousands of these in a loop, it can really bog +' down the processing due to the memory reallocations happening behind +' the scenes. In those cases it is better to use the Mid$() function to +' change an existing buffer to build the return string. + +' Special thanks to Nir Sofer - http://www.nirsoft.net/vb/strclass.html +' and Chris Lucas - http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=37141&lngWId=1 +' for their inspiration with these concepts. + +' Set this to any character or string to add after each +' call to `.Add()`. A common example would be vbCrLf. +Public AppendOnAdd As String + +' Set up an array of pages to hold strings +Private astrPages() As String +Private lngCurrentPage As Long +Private lngCurrentPos As Long +Private lngPageSize As Long +Private lngInitialPages As Long + +' These defaults can be tweaked as needed +Const clngPageSize As Long = 4096 +Const clngInitialPages As Long = 100 + + + +' Prepares the initial buffer page +Private Sub Class_Initialize() + + If lngPageSize = 0 Then lngPageSize = clngPageSize + If lngInitialPages = 0 Then lngInitialPages = clngInitialPages + + ' Set up the initial array of pages. + ReDim astrPages(0 To lngInitialPages - 1) As String + + ' Prepare first page + astrPages(0) = Space$(lngPageSize) + +End Sub + + +' Add 1 or more strings (avoiding the string conversion of paramarray) +Public Sub Add(str1 As String, Optional str2 As String, Optional str3 As String, Optional str4 As String, Optional str5 As String, _ + Optional str6 As String, Optional str7 As String, Optional str8 As String, Optional str9 As String, Optional str10 As String) + If str1 <> vbNullString Then AddString str1 + If str2 <> vbNullString Then AddString str2 + If str3 <> vbNullString Then AddString str3 + If str4 <> vbNullString Then AddString str4 + If str5 <> vbNullString Then AddString str5 + If str6 <> vbNullString Then AddString str6 + If str7 <> vbNullString Then AddString str7 + If str8 <> vbNullString Then AddString str8 + If str9 <> vbNullString Then AddString str9 + If str10 <> vbNullString Then AddString str10 + AddString AppendOnAdd +End Sub + + +' Add to the string buffer +Private Sub AddString(strAddString As String) + + Dim lngLen As Long + Dim lngRemaining As Long + Dim lngAddStrPos As Long + Dim lngAddLen As Long + + ' Get length of new string + lngLen = Len(strAddString) + + ' No need to process a zero-length string + If lngLen > 0 Then + ' Set starting position for string we are adding + lngAddStrPos = 1 + + ' Continue filling pages till we reach the end of the new string + Do While lngAddStrPos <= lngLen + + ' Check to see if we need a new page + If lngCurrentPos = lngPageSize Then + ' See if we already have a new page available in the array + If lngCurrentPage = UBound(astrPages) Then + ' Need to add a page to the array. + ReDim Preserve astrPages(0 To lngCurrentPage + 1) + End If + ' Prepare page as a buffer + lngCurrentPage = lngCurrentPage + 1 + astrPages(lngCurrentPage) = Space$(lngPageSize) + lngCurrentPos = 0 + End If + + ' See if it fits on the current page + lngRemaining = lngPageSize - lngCurrentPos + If (lngLen - (lngAddStrPos - 1)) <= lngRemaining Then + ' Yes, add to current page. + lngAddLen = (lngLen - (lngAddStrPos - 1)) + Mid$(astrPages(lngCurrentPage), lngCurrentPos + 1, lngAddLen) = Mid$(strAddString, lngAddStrPos) + lngAddStrPos = lngLen + 1 + lngCurrentPos = lngCurrentPos + lngAddLen + Else + ' Fill remaining available space on current page. + Mid$(astrPages(lngCurrentPage), lngCurrentPos + 1, lngRemaining) = Mid$(strAddString, lngAddStrPos, lngRemaining) + ' Note position in new string + lngCurrentPos = lngPageSize + lngAddStrPos = lngAddStrPos + lngRemaining + End If + + ' Move to next page, if needed + Loop + + End If + +End Sub + + +' Removes the specified number of chacters from the string. +' (Technically just moves the position back) +Public Sub Remove(lngChars As Long) + + Dim lngTotalLen As Long + Dim lngNewPosition As Long + + ' Get total length of current string including all pages + lngTotalLen = lngCurrentPos + (lngCurrentPage * lngPageSize) + + ' We can't remove more characters than we put in the string to start with. + If lngChars > lngTotalLen Then + ' Go to beginning + lngCurrentPage = 0 + lngCurrentPos = 1 + Else + ' Get new absolute position + lngNewPosition = lngTotalLen - lngChars + ' Calculate full pages + lngCurrentPage = (lngNewPosition \ lngPageSize) + ' Set position on partial page + lngCurrentPos = lngNewPosition - (lngCurrentPage * lngPageSize) + End If + +End Sub + + +' Returns the accumulated string +Public Function GetStr() As String + + Dim lngCnt As Long + + ' Prepare return string. This should be the filled pages plus the last + ' partial page, divided by 2 to get the string length instead of byte length. + GetStr = Space$((lngCurrentPage * lngPageSize) + lngCurrentPos) + + ' Loop through filled pages, overlaying on return string. + ' (Last partial page is automatically trimmed based on returned string size.) + ' (If lngCurrentPos=0 then skip last page) + If Len(GetStr) > 0 Then + For lngCnt = 0 To lngCurrentPage - Abs(CBool(lngCurrentPos = 0)) + Mid$(GetStr, (lngCnt * lngPageSize) + 1, lngPageSize) = astrPages(lngCnt) + Next lngCnt + End If + +End Function + + +' Return a partial string from a specified position +Public Function MidStr(lngStart As Long, Optional lngLength As Long = -1) As String + + Dim lngPage As Long + Dim lngPos As Long + Dim lngStartPage As Long + Dim lngStartPos As Long + + ' Prepare return string length. + If lngLength = -1 Then + ' Return remaining string after lngStart + lngLength = (Length - lngStart) + 1 + MidStr = Space$(lngLength) + Else + ' Return a specified number of characters + MidStr = Space$(lngLength) + End If + + ' Determine start page and position for return string + lngStartPage = (lngStart - 1) \ lngPageSize ' Zero based page + lngStartPos = lngStart - (lngStartPage * lngPageSize) + + ' Loop through filled pages, overlaying on return string. + ' (Last partial page is automatically trimmed based on returned string size.) + If Len(MidStr) > 0 Then + For lngPage = lngStartPage To lngCurrentPage + ' Could start at any point on first page + If lngPage = lngStartPage Then + Mid$(MidStr, 1) = Mid$(astrPages(lngPage), lngStartPos) + ' lngPos is the current position in the new string + lngPos = lngPageSize - (lngStartPos - 2) + Else + ' Pull whole pages as needed + Mid$(MidStr, lngPos) = astrPages(lngPage) + lngPos = lngPos + lngPageSize + End If + ' Exit when we have filled the requested string. + If lngPos > lngLength Then Exit For + Next lngPage + End If + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : RTrim +' Author : Adam Waller +' Date : 8/14/2023 +' Purpose : Trim trailing whitespace from content +'--------------------------------------------------------------------------------------- +' +Public Function RTrim(Optional strTrimChars As String = " ") + Do + If Length < Len(strTrimChars) Then Exit Do + If RightStr(Len(strTrimChars)) = strTrimChars Then + Remove Len(strTrimChars) + Else + Exit Do + End If + Loop +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : Right +' Author : Adam Waller +' Date : 11/5/2020 +' Purpose : Return the rightmost specified number of characters. +'--------------------------------------------------------------------------------------- +' +Public Function RightStr(lngLength As Long) As String + If Length > lngLength Then + RightStr = MidStr((Length - lngLength) + 1) + Else + RightStr = GetStr + End If +End Function + + +' returns the length of the string, based on the current position +' (Faster than building the string just to check the length) +Public Function Length() As Double + Length = (lngCurrentPage * lngPageSize) + lngCurrentPos +End Function + + +' Reset the buffer without changing the page size +Public Sub Clear() + + Class_Initialize + + ' Reset positions + lngCurrentPage = 0 + lngCurrentPos = 0 + +End Sub + + +' Manually set page size if you want something different from the default. +Public Sub SetPageSize(lngNewPageSize As Long, Optional lngNewInitialPages As Long) + If lngCurrentPage > 0 Or lngCurrentPos > 1 Then + MsgBox "Please set the page size before adding any data", vbExclamation, "Error in clsConcat" + Else + lngPageSize = lngNewPageSize + If lngNewInitialPages > 0 Then lngInitialPages = lngNewInitialPages + ' Reinitialize with the updated sizes + Class_Initialize + End If +End Sub + + +' Test the class to make sure we are paging correctly. +Public Sub SelfTest() + + SetPageSize 10, 5 + + Debug.Assert UBound(astrPages) = 4 + Add "abcdefghij" + Add "k" + Debug.Assert Len(GetStr) = 11 + Debug.Assert Length = 11 + Remove 2 + Debug.Assert Len(GetStr) = 9 + Add "jkl" + Debug.Assert Len(GetStr) = 12 + Debug.Assert GetStr = "abcdefghijkl" + Add "m123456789" + Remove 11 + Debug.Assert GetStr = "abcdefghijk" + Debug.Assert MidStr(1, 1) = "a" + Debug.Assert MidStr(11, 1) = "k" + Debug.Assert MidStr(2, 3) = "bcd" + Debug.Assert MidStr(8) = "hijk" + Debug.Assert MidStr(10, 1) = "j" + Debug.Assert RightStr(1) = "k" + Debug.Assert RightStr(100) = "abcdefghijk" + + ' Verify paging + Clear + SetPageSize 5, 2 + Add "1234" + Debug.Assert GetStr = "1234" + Add "5" + Debug.Assert GetStr = "12345" + Add "6" + Debug.Assert GetStr = "123456" + Add "789" + Debug.Assert GetStr = "123456789" + Add "0" + Debug.Assert GetStr = "1234567890" + Add "A" + Debug.Assert GetStr = "1234567890A" + Remove 1 + Debug.Assert GetStr = "1234567890" + Remove 1 + Debug.Assert GetStr = "123456789" + Add "0A" + Debug.Assert GetStr = "1234567890A" + Remove 2 + Debug.Assert GetStr = "123456789" + Add "0A" + Debug.Assert GetStr = "1234567890A" +End Sub + + diff --git a/CodeStore/index.xlsm_stdArray.bas b/CodeStore/index.xlsm_stdArray.bas new file mode 100644 index 0000000..0593d3c --- /dev/null +++ b/CodeStore/index.xlsm_stdArray.bas @@ -0,0 +1,870 @@ +Attribute VB_Name = "stdArray" +'@TODO: +'* Implement Exceptions throughout all Array functions. +'* Fully implement pInitialised where necessary. +'* Build Methods Slice; Splice; Sort +'* Add methods from ruby +'* Documentation of methods + +#If VBA6 Then + Private Declare PtrSafe Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long) +#Else + Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) +#End If +Private Enum SortDirection + Ascending = 1 + Descending = 2 +End Enum +Private Type SortStruct + value As Variant + sortValue As Variant +End Type + +Private pArr() As Variant +Private pProxyLength As Long +Private pLength As Long + +Private pChunking As Long +Private pInitialised As Boolean + + + +Public Event BeforeArrLet(ByRef arr As stdArray, ByRef arr As Variant) +Public Event AfterArrLet(ByRef arr As stdArray, ByRef arr As Variant) +Public Event BeforeAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean) +Public Event AfterAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant) +Public Event BeforeRemove(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean) +Public Event AfterRemove(ByRef arr As stdArray, ByVal iIndex As Long) +Public Event AfterClone(ByRef Clone As stdArray) +Public Event AfterCreate(ByRef arr As stdArray) + +'Create a stdArray object from params +'@param {paramarray variant()} The items of the array +'@returns {stdArray} A stdArray from the parameters. +Public Function Create(ParamArray params() As Variant) As stdArray + Set Create = New stdArray + + Dim i As Long + Dim lb As Long: lb = LBound(params) + Dim ub As Long: ub = UBound(params) + + Call Create.Init(ub - lb + 1, 10) + + For i = lb To ub + Call Create.Push(params(i)) + Next + + 'Raise AfterCreate event + RaiseEvent AfterCreate(Create) +End Function + +'Create a stdArray object from params +'@param {Long} The length of the initial private array created +'@param {Long} The number of items the private array is increased by when required. +'@param {paramarray variant()} The items of the array +'@returns {stdArray} A stdArray from the parameters. +Public Function CreateWithOptions(ByVal iInitialLength As Long, ByVal iChunking As Long, ParamArray params() As Variant) As stdArray + Set CreateWithOptions = New stdArray + + Dim i As Long + Dim lb As Long: lb = LBound(params) + Dim ub As Long: ub = UBound(params) + + Call CreateWithOptions.Init(iInitialLength, iChunking) + For i = lb To ub + Call CreateWithOptions.Push(params(i)) + Next + + 'Raise AfterCreate event + RaiseEvent AfterCreate(Create) +End Function + +'Create a stdArray object from a VBA array +'@param {variant()} Variant array to create a `stdArray` object from. +'@returns {stdArray} Returns `stdArray` of variants. +Public Function CreateFromArray(ByVal arr As Variant) As stdArray + Set CreateFromArray = New stdArray + + Dim i As Long + Dim lb As Long: lb = LBound(arr) + Dim ub As Long: ub = UBound(arr) + Call CreateFromArray.Init(ub - lb + 1, 10) + + For i = lb To ub + Call CreateFromArray.Push(arr(i)) + Next + + 'Raise AfterCreate event + RaiseEvent AfterCreate(Create) +End Function + +'Create an array by splitting a string +'@param {string} Haystack to split +'@param {string?=","} Delimiter +'@returns {stdArray} A list of strings +Public Function CreateFromString(ByVal sHaystack As String, Optional ByVal sDelimiter As String = ",") As stdArray + Set CreateFromString = CreateFromArray(Split(sHaystack, sDelimiter)) +End Function + +'Initialise array +'@param {Long} The length of the initial private array created +'@param {Long} The number of items the private array is increased by when required. +Friend Sub Init(ByVal iInitialLength As Long, ByVal iChunking As Long) + If iChunking > iInitialLength Then iInitialLength = iChunking + If Not pInitialised Then + pProxyLength = iInitialLength + ReDim pArr(1 To iInitialLength) As Variant + pChunking = iChunking + pInitialised = True + End If +End Sub + +'Obtain a collection from the data contained within the array. Primarily used for NewEnum() method. +'@returns {Collection} Collection from Array +Public Function AsCollection() As collection + Set AsCollection = New collection + Dim i As Long + For i = 1 To Length() + AsCollection.Add pArr(i) + Next +End Function + +'For-each compatibility +'@protected +'@returns {IEnumVARIANT} An enumerator with methods enumNext, enumRefresh etc. +'@usage `For each obj in myEnum: ... : next` +'@TODO: Use custom IEnumVARIANT instead of casting to Collection +Public Property Get NewEnum() As IUnknown + Static oEnumCol As collection: If oEnumCol Is Nothing Then Set oEnumCol = AsCollection() + Set NewEnum = oEnumCol.[_NewEnum] +End Property + +'Obtain the length of the array +Public Property Get Length() As Long + Length = pLength +End Property + +'Obtain the length of the private array which stores the data of this array class +Public Property Get zProxyLength() As Long + zProxyLength = pProxyLength +End Property + +'Resize the array to a length +'@param {Long} The length of the desired array +Public Sub Resize(ByVal iLength As Long) + pLength = iLength +End Sub + +'Rechunk the private array to the length / number of items. +Public Sub Rechunk() + Dim fNumChunks As Double, iNumChunks As Long + fNumChunks = pLength / pChunking + iNumChunks = CLng(fNumChunks) + If fNumChunks > iNumChunks Then iNumChunks = iNumChunks + 1 + + ReDim Preserve pArr(1 To iNumChunks * pChunking) As Variant +End Sub + + +'Sort the array +'@param {stdICallable<(variant)=>variant>} A mapping function which should map whatever the input is to whatever variant the array should be sorted on. +'@param {stdICallable<(variant,variant)=>boolean>} Comparrison function which consumes 2 variants and generates a boolean. See implementation of `Sort_QuickSort` for details. +'@param {long} Currently only 1 algorithm: 0 - Quicksort +'@param {boolean} Sort the array in place. Sorting in-place is prefferred if possible as it is much more performant. +'@returns {stdArray} +Public Function Sort(Optional ByVal cbSortBy As stdICallable = Nothing, Optional ByVal cbComparrason As stdICallable = Nothing, Optional ByVal iAlgorithm As Long = 0, Optional ByVal bSortInPlace As Boolean = False) As stdArray + If Not bSortInPlace Then + Set Sort = Clone().Sort(cbSortBy, cbComparrason, iAlgorithm, True) + Else + If Length() = 0 Then + Set Sort = Me + Exit Function + End If + + Dim arr() As SortStruct + ReDim arr(1 To Length()) As SortStruct + + Dim i As Long + + 'Copy array to sort structures + For i = 1 To Length() + Call CopyVariant(arr(i).value, pArr(i)) + If cbSortBy Is Nothing Then + Call CopyVariant(arr(i).sortValue, pArr(i)) + Else + Call CopyVariant(arr(i).sortValue, cbSortBy.Run(pArr(i))) + End If + Next + + 'Call sort algorithm + Select Case iAlgorithm + Case 0 'QuickSort + Call Sort_QuickSort(arr, cbComparrason) + Case Else + stdError.Raise "Invalid sorting algorithm specified" + End Select + + 'Copy sort structures to array + For i = 1 To Length() + Call CopyVariant(pArr(i), arr(i).value) + Next + + 'Return array + Set Sort = Me + End If +End Function + +'QuickSort3 +' Src: https://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-%28sort-array-sorting-arrays%29 +' Omit plngLeft & plngRight; they are used internally during recursion +Private Sub Sort_QuickSort(ByRef pvarArray() As SortStruct, Optional cbComparrison As stdICallable = Nothing, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long) + Dim lngFirst As Long + Dim lngLast As Long + Dim varMid As SortStruct + Dim varSwap As SortStruct + + If plngRight = 0 Then + plngLeft = 1 + plngRight = Length() + End If + lngFirst = plngLeft + lngLast = plngRight + varMid = pvarArray((plngLeft + plngRight) \ 2) + Do + If cbComparrison Is Nothing Then + Do While pvarArray(lngFirst).sortValue < varMid.sortValue And lngFirst < plngRight + lngFirst = lngFirst + 1 + Loop + Do While varMid.sortValue < pvarArray(lngLast).sortValue And lngLast > plngLeft + lngLast = lngLast - 1 + Loop + Else + Do While cbComparrison.Run(pvarArray(lngFirst).sortValue, varMid.sortValue) And lngFirst < plngRight + lngFirst = lngFirst + 1 + Loop + Do While cbComparrison.Run(varMid.sortValue, pvarArray(lngLast).sortValue) And lngLast > plngLeft + lngLast = lngLast - 1 + Loop + End If + + If lngFirst <= lngLast Then + varSwap = pvarArray(lngFirst) + pvarArray(lngFirst) = pvarArray(lngLast) + pvarArray(lngLast) = varSwap + lngFirst = lngFirst + 1 + lngLast = lngLast - 1 + End If + Loop Until lngFirst > lngLast + If plngLeft < lngLast Then Sort_QuickSort pvarArray, cbComparrison, plngLeft, lngLast + If lngFirst < plngRight Then Sort_QuickSort pvarArray, cbComparrison, lngFirst, plngRight +End Sub + + + + +'Obtain the array as a regular VBA array +Public Property Get arr() As Variant + If pLength = 0 Then + arr = Array() + Else + Dim vRet() As Variant + ReDim vRet(1 To pLength) As Variant + For i = 1 To pLength + Call CopyVariant(vRet(i), pArr(i)) + Next + arr = vRet + End If +End Property +Public Property Let arr(v As Variant) + RaiseEvent BeforeArrLet(Me, v) + Dim lb As Long: lb = LBound(v) + Dim ub As Long: ub = UBound(v) + Dim cnt As Long: cnt = ub - lb + 1 + ReDim pArr(1 To (Int(cnt / pChunking) + 1) * pChunking) As Variant + For i = lb To ub + Call Push(pArr(i)) + Next + RaiseEvent AfterArrLet(Me, v) +End Property + +'Add an element to the end of the array +'@param {variant} The element to add to the end of the array. +'@returns {stdArray} me +'TODO: Add multiple elements with push +Public Function Push(ByVal el As Variant) As stdArray + If pInitialised Then + 'Before Add event + Dim bCancel As Boolean + RaiseEvent BeforeAdd(Me, pLength + 1, el, bCancel) + If bCancel Then Exit Function + + If pLength = pProxyLength Then + pProxyLength = pProxyLength + pChunking + ReDim Preserve pArr(1 To pProxyLength) As Variant + End If + + pLength = pLength + 1 + CopyVariant pArr(pLength), el + + 'After add event + RaiseEvent AfterAdd(Me, pLength, pArr(pLength)) + + Set Push = Me + Else + 'Error + End If +End Function + +'Remove an element from the end of the array +'@returns {variant} The element removed from the array +Public Function Pop() As Variant + If pInitialised Then + If pLength > 0 Then + 'Raise BeforeRemove event and optionally cancel + Dim bCancel As Boolean + RaiseEvent BeforeRemove(Me, pLength, pArr(pLength), bCancel) + If bCancel Then Exit Function + + CopyVariant Pop, pArr(pLength) + pLength = pLength - 1 + + 'Raise AfterRemove event + RaiseEvent AfterRemove(Me, pLength) + Else + Pop = Empty + End If + Else + 'Error + End If +End Function + +'Remove the ith element from the array +'@param {Long} Index of the element to remove +'@returns {Variant} The element removed +Public Function Remove(ByVal index As Long) As Variant + 'Ensure initialised + If pInitialised Then + 'Ensure length > 0 + If pLength > 0 Then + 'Ensure index < length + If index <= pLength Then + 'Raise BeforeRemove event and optionally cancel + Dim bCancel As Boolean + RaiseEvent BeforeRemove(Me, index, pArr(index), bCancel) + If bCancel Then Exit Function + + 'Copy party we are removing to return variable + CopyVariant Remove, pArr(index) + + 'Loop through array from removal, set i-1th element to ith element + Dim i As Long + For i = index + 1 To pLength + pArr(i - 1) = pArr(i) + Next + + 'Set last element length and subtract total length by 1 + pArr(pLength) = Empty + pLength = pLength - 1 + + 'Raise after remove event + RaiseEvent AfterRemove(Me, index) + Else + 'Error + End If + Else + 'Error + End If + Else + 'Error + End If +End Function + +'Remove and return element from the start of the array +'@returns {variant} Element removed +Public Function Shift() As Variant + 'Would be good to use CopyMemory here + + CopyVariant Shift, pArr(1) + Dim i As Long + For i = 1 To pLength - 1 + pArr(i) = pArr(i + 1) + Next + pLength = pLength - 1 +End Function + +'Insert an element onto the start of the array +'@param {Variant} Value to append to the start of the array +'@returns {stdArray} me +Public Function Unshift(val As Variant) As stdArray + 'Would be good to use CopyMemory here + + 'Before Add event + Dim bCancel As Boolean + RaiseEvent BeforeAdd(Me, 1, val, bCancel) + If bCancel Then Exit Function + + 'Ensure array is big enough and increase pLength + If pLength = pProxyLength Then + pProxyLength = pProxyLength + pChunking + ReDim Preserve pArr(1 To pProxyLength) As Variant + End If + pLength = pLength + 1 + + 'Unshift + For i = pLength - 1 To 1 Step -1 + pArr(i + 1) = pArr(i) + Next + pArr(1) = val + + 'After Add event + RaiseEvent AfterAdd(Me, 1, val) + + Set Unshift = Me +End Function + +'TODO: +'Public Function Slice() As stdArray +' +'End Function + +'TODO: +'Public Function Splice() As stdArray +' +'End Function + +'Creates a new instance of the same array +'@returns {stdArray} +Public Function Clone() As stdArray + If pInitialised Then + If pInitialised Then + 'Similar to CreateFromArray() but passing length through also: + Set Clone = New stdArray + + Call Clone.Init(pLength, 10) + + Dim i As Long + For i = 1 To pLength + Call Clone.Push(pArr(i)) + Next + Else + 'Error + End If + + RaiseEvent AfterClone(Clone) + Else + 'Error + End If +End Function + +'Returns a new array with all elements in reverse order +'@returns {stdArray} +Public Function Reverse() As stdArray + 'TODO: Need to find a better more low level approach to creating arrays from existing arrays/preventing redim for methods like this + Dim ret As stdArray + Set ret = stdArray.Create() + For i = pLength To 1 Step -1 + Call ret.Push(pArr(i)) + Next + Set Reverse = ret +End Function + +'Concatenate an existing array of elements onto the end of this array +'@param {stdArray} Array whose elements we wish to append to the end of this array +'@returns {stdArray} New composite array. +Public Function Concat(ByVal arr As stdArray) As stdArray + Dim x As stdArray + Set x = Clone() + + If Not arr Is Nothing Then + Dim i As Long + For i = 1 To arr.Length + Call x.Push(arr.item(i)) + Next + End If + + Set Concat = x +End Function + +'Join each of the elements of this array together as a string +'@param {string} Delimiter to insert between strings +Public Function Join(Optional ByVal delimeter As String = ",") As String + If pInitialised Then + If pLength > 0 Then + Dim sOutput As String + sOutput = pArr(1) + + Dim i As Long + For i = 2 To pLength + sOutput = sOutput & delimeter & pArr(i) + Next + Join = sOutput + Else + Join = "" + End If + Else + 'Error + End If +End Function + +'Get/Let/Set item +'@param {long} The location to get/set the item +Public Property Get item(ByVal i As Long) As Variant + 'item(1) = 1st element + 'item(2) = 2nd element + 'etc. + CopyVariant item, pArr(i) + +End Property +Public Property Set item(ByVal i As Long, ByVal item As Object) + Set pArr(i) = item +End Property +Public Property Let item(ByVal i As Long, ByVal item As Variant) + pArr(i) = item +End Property + +'Copy a variant into the array's ith element. This saves from having to test the item and call the correct `set` keyword +'@param {Long} The index at which the item's data should be set +'@param {ByRef Variant} Item to set at the index +Public Sub PutItem(ByVal i As Long, ByRef item As Variant) + CopyVariant pArr(i), item +End Sub + +'Obtain the index of an element +'@param {Variant} Element to find +'@param {Ingeger?=1} Location to start search for element. +'@returns {long} Index of element +Public Function indexOf(ByVal el As Variant, Optional ByVal start As Long = 1) As Long + Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean + + 'Is element an object? + elIsObj = isObject(el) + + 'Loop over contents starting from start + For i = start To pLength + 'Get item data + CopyVariant item, pArr(i) + + 'Is item an object? + itemIsObj = isObject(item) + + 'If both item and el are objects (must be the same type in order to be the same data) + If itemIsObj And elIsObj Then + If item Is el Then 'check items equal + indexOf = i 'return item index + Exit Function + End If + 'If both item and el are not objects (must be the same type in order to be the same data) + ElseIf Not itemIsObj And Not elIsObj Then + If item = el Then 'check items equal + indexOf = i 'return item index + Exit Function + End If + End If + Next + + 'Return -1 i.e. no match found + indexOf = -1 +End Function + +'Obtain the last index of an element +'@param {Variant} Element to find +'@returns {long} Last index of element +Public Function lastIndexOf(ByVal el As Variant) + Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean + + 'Is element an object? + elIsObj = isObject(el) + + 'Loop over contents starting from start + For i = pLength To 1 Step -1 + 'Get item data + CopyVariant item, pArr(i) + + 'Is item an object? + itemIsObj = isObject(item) + + 'If both item and el are objects (must be the same type in order to be the same data) + If itemIsObj And elIsObj Then + If item Is el Then 'check items equal + lastIndexOf = i 'return item index + Exit Function + End If + 'If both item and el are not objects (must be the same type in order to be the same data) + ElseIf Not itemIsObj And Not elIsObj Then + If item = el Then 'check items equal + lastIndexOf = i 'return item index + Exit Function + End If + End If + Next + + 'Return -1 i.e. no match found + lastIndexOf = -1 +End Function + +'Returns true if the array contains an item +'@param {Variant} Item to find +'@param {long?=1} Index to start search for item at. (Internally uses indexOf()) +Public Function includes(ByVal el As Variant, Optional ByVal startFrom As Long = 1) As Boolean + includes = indexOf(el, startFrom) >= startFrom +End Function + + + + + +'Iterative Functions (All require stdICallable): + +'Example: if incidents.IsEvery(cbValid) then ... +Public Function IsEvery(ByVal cb As stdICallable) As Boolean + If pInitialised Then + Dim i As Long + For i = 1 To pLength + Dim bFlag As Boolean + bFlag = cb.Run(pArr(i)) + + If Not bFlag Then + IsEvery = False + Exit Function + End If + Next + + IsEvery = True + Else + 'Error + End If +End Function + +Public Function IsSome(ByVal cb As stdICallable) As Boolean + If pInitialised Then + Dim i As Long + For i = 1 To pLength + Dim bFlag As Boolean + bFlag = cb.Run(pArr(i)) + + If bFlag Then + IsSome = True + Exit Function + End If + Next + IsSome = False + Else + 'Error + End If +End Function + +Public Sub ForEach(ByVal cb As stdICallable) + If pInitialised Then + Dim i As Long + For i = 1 To pLength + Call cb.Run(pArr(i)) + Next + Else + 'Error + End If +End Sub + +Public Function Map(ByVal cb As stdICallable) As stdArray + If pInitialised Then + Dim pMap As stdArray + Set pMap = Clone() + + Dim i As Long + For i = 1 To pLength + 'BUGFIX: Sometimes required, not sure when + Dim v As Variant + CopyVariant v, item(i) + + 'Call callback + Call pMap.PutItem(i, cb.Run(v)) + Next + + Set Map = pMap + Else + 'Error + End If +End Function + + +'OPTIMISE: Needs optimisation. Currently very sub-optimal +Public Function Unique(Optional ByVal cb As stdICallable = Nothing) As stdArray + Dim ret As stdArray: Set ret = stdArray.CreateWithOptions(pLength, pChunking) + Dim retL As stdArray: Set retL = CreateWithOptions(pLength, pChunking) + + 'Collect keys + Dim vKeys As stdArray + If cb Is Nothing Then + Set vKeys = Clone() + Else + Set vKeys = Map(cb) + End If + + 'Unique by key + For i = 1 To pLength + If Not retL.includes(vKeys.item(i)) Then + Call retL.Push(vKeys.item(i)) + Call ret.Push(pArr(i)) + End If + Next + + 'Return data + Set Unique = ret +End Function + +Public Function reduce(ByVal cb As stdICallable, Optional ByVal initialValue As Variant) As Variant + Dim iStart As Long + If pInitialised Then + If pLength > 0 Then + If IsMissing(initialValue) Then + Call CopyVariant(reduce, pArr(1)) + iStart = 2 + Else + Call CopyVariant(reduce, initialValue) + iStart = 1 + End If + Else + If IsMissing(initialValue) Then + reduce = Empty + Else + Call CopyVariant(reduce, initialValue) + End If + Exit Function + End If + + Dim i As Long + For i = iStart To pLength + 'BUGFIX: Sometimes required, not sure when + Dim el As Variant + CopyVariant el, pArr(i) + + 'Reduce + CopyVariant reduce, cb.Run(reduce, el) + Next + Else + 'Error + End If +End Function + + +Public Function Filter(ByVal cb As stdICallable) As stdArray + Dim ret As stdArray + Set ret = stdArray.CreateWithOptions(pLength, pChunking) + Set Filter = ret + + 'If initialised... + If pInitialised Then + Dim i As Long, v As Variant + 'Loop over array + For i = 1 To pLength + 'If callback succeeds, push retvar + If cb.Run(pArr(i)) Then + Call ret.Push(pArr(i)) + End If + Next i + Else + 'error + End If +End Function + +Public Function count(Optional ByVal cb As stdICallable = Nothing) As Long + If cb Is Nothing Then + count = Length + Else + Dim i As Long, lCount As Long + lCount = 0 + For i = 1 To pLength + If cb.Run(pArr(i)) Then + lCount = lCount + 1 + End If + Next i + count = lCount + End If +End Function + +Public Function groupBy(ByVal cb As stdICallable) As Object + 'Array to store result in + Dim result As Object + Set result = CreateObject("Scripting.Dictionary") + + 'Loop over items + Dim i As Long + For i = 1 To pLength + 'Get grouping key + Dim key As Variant + key = cb.Run(pArr(i)) + + 'If key is not set then set it + If Not result.Exists(key) Then Set result(key) = stdArray.Create() + + 'Push item to key + result(key).Push pArr(i) + Next + + 'Return result + Set groupBy = result +End Function + +Public Function Max(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant + Dim vRet, vMaxValue, v + vMaxValue = startingValue: vRet = startingValue + For i = 1 To pLength + Call CopyVariant(v, pArr(i)) + + 'Get value to test + Dim vtValue As Variant + If cb Is Nothing Then + Call CopyVariant(vtValue, v) + Else + Call CopyVariant(vtValue, cb.Run(v)) + End If + + 'Compare values and return + If IsEmpty(vRet) Then + Call CopyVariant(vRet, v) + Call CopyVariant(vMaxValue, vtValue) + ElseIf vMaxValue < vtValue Then + Call CopyVariant(vRet, v) + Call CopyVariant(vMaxValue, vtValue) + End If + Next + + Call CopyVariant(Max, vRet) +End Function +Public Function Min(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant + Dim vRet, vMinValue, v + vMinValue = startingValue: vRet = startingValue + For i = 1 To pLength + Call CopyVariant(v, pArr(i)) + + 'Get value to test + Dim vtValue As Variant + If cb Is Nothing Then + Call CopyVariant(vtValue, v) + Else + Call CopyVariant(vtValue, cb.Run(v)) + End If + + 'Compare values and return + If IsEmpty(vRet) Then + Call CopyVariant(vRet, v) + Call CopyVariant(vMinValue, vtValue) + ElseIf vMinValue > vtValue Then + Call CopyVariant(vRet, v) + Call CopyVariant(vMinValue, vtValue) + End If + Next + + Call CopyVariant(Min, vRet) +End Function + +'Copies one variant to a destination +'@param {ByRef Variant} dest Destination to copy variant to +'@param {Variant} value Source to copy variant from. +'@perf This appears to be a faster variant of "oleaut32.dll\VariantCopy" + it's multi-platform +Private Sub CopyVariant(ByRef dest As Variant, ByVal value As Variant) + If isObject(value) Then + Set dest = value + Else + dest = value + End If +End Sub diff --git a/CodeStore/index.xlsm_stdICallable.bas b/CodeStore/index.xlsm_stdICallable.bas new file mode 100644 index 0000000..d758601 --- /dev/null +++ b/CodeStore/index.xlsm_stdICallable.bas @@ -0,0 +1,34 @@ +Attribute VB_Name = "stdICallable" + +'Call will call the passed function with param array +Public Function Run(ParamArray params() As Variant) As Variant: End Function + +'Call function with supplied array of params +Public Function RunEx(ByVal params As Variant) As Variant: End Function + +'Bind a parameter to the function +Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function + +'Making late-bound calls to stdICallable members +'@protected +'@param {ByVal String} - Message to send +'@param {ByRef Boolean} - Whether the call was successful +'@param {ByVal Variant} - Any variant, typically parameters as an array. Passed along with the message. +'@returns {Variant} - Any return value. +Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function + +'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is +'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to +'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in +'real life applications. +'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway + ''Returns a callback function + ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` + ''If this cannot be implemented return 0 + 'Public Function ToPointer() as long + +''Bind arguments to functions to appear as first arguments in call. +''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() +'Public Function Bind(ByVal v as variant) as stdICallable: End Function + + diff --git a/CodeStore/index.xlsm_stdLambda.bas b/CodeStore/index.xlsm_stdLambda.bas new file mode 100644 index 0000000..8a2204d --- /dev/null +++ b/CodeStore/index.xlsm_stdLambda.bas @@ -0,0 +1,1817 @@ +Attribute VB_Name = "stdLambda" + +'Ensure Option-Explicit is disabled!! +'For VB6 compatibility we rely on the auto-definition of Application and ThisWorkbook +'Option Explicit + +'Used for enabling some debugging features +#Const devMode = True + +'For Mac testing purposes only +'#const Mac = true + + + +'Implement stdICallable interface +Implements stdICallable + +'Direct call convention of VBA.CallByName +#If Not Mac Then + #If VBA7 Then + 'VBE7 is interchangable with msvbvm60.dll however VBE7.dll appears to always be present where as msvbvm60 is only occasionally present. + Private Declare PtrSafe Function rtcCallByName Lib "VBE7.dll" (ByVal cObj As Object, ByVal sMethod As LongPtr, ByVal eCallType As VbCallType, ByRef pArgs() As Variant, ByVal lcid As Long) As Variant + #Else + Private Declare Function rtcCallByName Lib "msvbvm60" (ByVal cObj As Object, ByVal sMethod As Long, ByVal eCallType As VbCallType, ByRef pArgs() As Variant, ByVal lcid As Long) As Variant + #End If +#End If + + +'Tokens, token definitions and operations +Private Type TokenDefinition + name As String + Regex As String + RegexObj As Object +End Type +Private Type token + Type As TokenDefinition + value As Variant + BracketDepth As Long +End Type +Private Type Operation + Type As iType + subType As ISubType + value As Variant +End Type + +'Evaluation operation types +Private Enum iType + oPush = 1 + oPop = 2 + oMerge = 3 + oAccess = 4 + oSet = 5 + oArithmetic = 6 + oLogic = 7 + oFunc = 8 + oComparison = 9 + oMisc = 10 + oJump = 11 + oReturn = 12 + oObject = 13 +End Enum +Private Enum ISubType + 'Arithmetic + oAdd = 1 + oSub = 2 + oMul = 3 + oDiv = 4 + oPow = 5 + oNeg = 6 + oMod = 7 + 'Logic + oAnd = 8 + oOr = 9 + oNot = 10 + oXor = 11 + 'comparison + oEql = 12 + oNeq = 13 + oLt = 14 + oLte = 15 + oGt = 16 + oGte = 17 + oIs = 18 + 'misc operators + oCat = 19 + oLike = 20 + 'misc + ifTrue = 21 + ifFalse = 22 + withValue = 23 + argument = 24 + 'object + oPropGet = 25 + oPropLet = 26 + oPropSet = 27 + oMethodCall = 28 + oFieldCall = 29 + oEquality = 30 'Yet to be implemented + oIsOperator = 31 'Yet to be implemented + oEnum = 32 'Yet to be implemented +End Enum + +'Special constant used in parsing: +Const UniqueConst As String = "3207af79-30df-4890-ade1-640f9f28f309" + +Private tokens() As token +Private iTokenIndex As Long +Private operations() As Operation +Private iOperationIndex As Long +Private stackSize As Long +Private scopes() As Variant +Private scopesArgCount() As Variant +Private scopeCount As Long +Private funcScope As Long +Private pEquation As String + +Private Enum LambdaType + iStandardLambda = 1 + iBoundLambda = 2 +End Enum + + +Const minStackSize = 30 'note that the stack size may become smaller than this + +'@protected +Public oFunctExt As Object 'Dictionary stdCallback> + +Private oCache As Object +Private bBound As Boolean +Private oBound As stdLambda +Private vBound As Variant +Private bUsePerformanceCache As Boolean +Private pPerformanceCache As Object + +''Usage: +'Debug.Print stdLambda.Create("1+3*8/2*(2+2+3)").Execute() +'With stdLambda.Create("$1+1+3*8/2*(2+2+3)") +' Debug.Print .Execute(10) +' Debug.Print .Execute(15) +' Debug.Print .Execute(20) +'End With +'Debug.Print stdLambda.Create("$1.Range(""A1"")").Execute(Sheets(1)).Address(True, True, xlA1, True) +'Debug.Print stdLambda.Create("$1.join("","")").Execute(stdArray.Create(1,2)) +Public Function Create(ByVal sEquation As String, Optional ByVal bUsePerformanceCache As Boolean = False, Optional ByVal bSandboxExtras As Boolean = False) As stdLambda + 'Cache Lambda created + If oCache Is Nothing Then Set oCache = CreateObject("Scripting.Dictionary") + Dim sID As String: sID = bUsePerformanceCache & "-" & bSandboxExtras & ")" & sEquation + If Not oCache.Exists(sID) Then + Set oCache(sID) = New stdLambda + Call oCache(sID).Init(LambdaType.iStandardLambda, sEquation, bUsePerformanceCache, bSandboxExtras) + End If + + 'Return cached lambda + Set Create = oCache(sID) +End Function + +Public Function CreateMultiline(ByRef sEquation As Variant, Optional ByVal bUsePerformanceCache As Boolean = False, Optional ByVal bSandboxExtras As Boolean = False) As stdLambda + Set CreateMultiline = Create(Join(sEquation, " "), bUsePerformanceCache, bSandboxExtras) +End Function + +Public Function BindEx(ByVal params As Variant) As stdLambda + Set BindEx = New stdLambda + Dim callable As stdICallable: Set callable = Me + Call BindEx.Init(LambdaType.iBoundLambda, callable, params) +End Function + +'Bind a global variable to the function +'@param {String} - New global name +'@param {Variant}- Data to store in global variable +'@returns {stdLambda} The lambda existing lambda +Public Function BindGlobal(ByVal sGlobalName As String, ByVal variable As Variant) As stdLambda + Set BindGlobal = Me + If bBound Then + Call oBound.BindGlobal(sGlobalName, variable) + Else + If oFunctExt Is Nothing Then Set oFunctExt = CreateObject("Scripting.Dictionary") + If isObject(variable) Then + Set oFunctExt(sGlobalName) = variable + Else + Let oFunctExt(sGlobalName) = variable + End If + End If +End Function + + +Public Sub Init(ByVal iLambdaType As Long, ParamArray params() As Variant) + Select Case iLambdaType + Case LambdaType.iStandardLambda + Dim sEquation As String: sEquation = params(0) + pEquation = sEquation + bUsePerformanceCache = params(1) + Dim bSandboxExtras As Boolean: bSandboxExtras = params(2) + + 'Performance cache + If bUsePerformanceCache Then Set pPerformanceCache = CreateObject("Scripting.Dictionary") + + 'Function extensions + Set oFunctExt = stdLambda.oFunctExt + If bSandboxExtras Or oFunctExt Is Nothing Then Set oFunctExt = CreateObject("Scripting.Dictionary") + + bBound = False + tokens = Tokenise(sEquation) + iTokenIndex = 1 + iOperationIndex = 0 + stackSize = 0 + scopeCount = 0 + funcScope = 0 + Call parseBlock("eof") + Call finishOperations + + Case LambdaType.iBoundLambda + bBound = True + Set oBound = params(0) + vBound = params(1) + pEquation = "BOUND..." + + 'Function extensions + Set oFunctExt = stdLambda.oFunctExt + If bSandboxExtras Or oFunctExt Is Nothing Then Set oFunctExt = CreateObject("Scripting.Dictionary") + Case Else + Err.Raise 1, "stdLambda::Init", "No lambda with that type." + End Select +End Sub + +Private Function stdICallable_Run(ParamArray params() As Variant) As Variant + If Not bBound Then + 'Execute top-down parser + Call CopyVariant(stdICallable_Run, evaluate(operations, params)) + Else + Call CopyVariant(stdICallable_Run, oBound.RunEx(ConcatArrays(vBound, params))) + End If +End Function +Private Function stdICallable_RunEx(ByVal params As Variant) As Variant + If Not isArray(params) Then + Err.Raise 1, "params to be supplied as array of arguments", "" + End If + + If Not bBound Then + 'Execute top-down parser + Call CopyVariant(stdICallable_RunEx, evaluate(operations, params)) + Else + Call CopyVariant(stdICallable_RunEx, oBound.RunEx(ConcatArrays(vBound, params))) + End If +End Function + +Function Run(ParamArray params() As Variant) As Variant + If Not bBound Then + 'Execute top-down parser + Call CopyVariant(Run, evaluate(operations, params)) + Else + Call CopyVariant(Run, oBound.RunEx(ConcatArrays(vBound, params))) + End If +End Function + +Function RunEx(ByVal params As Variant) As Variant + If Not bBound Then + If Not isArray(params) Then + Err.Raise 1, "params to be supplied as array of arguments", "" + End If + + 'Execute top-down parser + Call CopyVariant(RunEx, evaluate(operations, params)) + Else + Call CopyVariant(RunEx, oBound.RunEx(ConcatArrays(vBound, params))) + End If +End Function + +'Bind a parameter to the function +Private Function stdICallable_Bind(ParamArray params() As Variant) As stdICallable + Set stdICallable_Bind = BindEx(params) +End Function +Public Function Bind(ParamArray params() As Variant) As stdLambda + Set Bind = BindEx(params) +End Function + +'Low-dependency function calling +'@protected +'@param {ByVal String} - Message to send +'@param {ByRef Boolean} - Success of message. If message wasn't processed return false. +'@param {Paramarray Variant} - Parameters to pass along with message +'@returns {Variant} - Anything returned by the function +Private Function stdICallable_SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant + Select Case sMessage + Case "obj" + Set stdICallable_SendMessage = Me + success = True + Case "className" + stdICallable_SendMessage = "stdLambda" + success = True + Case "bindGlobal" + 'Bind global based whether this is a bound lambda or not + Call BindGlobal(params(0), params(1)) + success = True + Case Else + success = False + End Select +End Function + +'================ +' +' TOKENISATION +' +'================ + + +'Tokeniser helpers +Private Function getTokenDefinitions() As TokenDefinition() + Dim arr() As TokenDefinition + ReDim arr(1 To 99) + + Dim i As Long: i = 0 + 'Whitespace + i = i + 1: arr(i) = getTokenDefinition("space", "\s+") 'String + + 'Literal + i = i + 1: arr(i) = getTokenDefinition("literalString", """(?:""""|[^""])*""") 'String + i = i + 1: arr(i) = getTokenDefinition("literalNumber", "\d+(?:\.\d+)?") 'Number + i = i + 1: arr(i) = getTokenDefinition("literalBoolean", "True|False", isKeyword:=True) + + 'Named operators + i = i + 1: arr(i) = getTokenDefinition("is", "is", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("mod", "mod", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("and", "and", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("or", "or", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("xor", "xor", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("not", "not", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("like", "like", isKeyword:=True) + + 'Structural + ' Inline if + i = i + 1: arr(i) = getTokenDefinition("if", "if", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("then", "then", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("else", "else", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("end", "end", isKeyword:=True) + ' Brackets + i = i + 1: arr(i) = getTokenDefinition("lBracket", "\(") + i = i + 1: arr(i) = getTokenDefinition("rBracket", "\)") + ' Functions + i = i + 1: arr(i) = getTokenDefinition("fun", "fun", isKeyword:=True) + i = i + 1: arr(i) = getTokenDefinition("comma", ",") 'params + ' Lines + i = i + 1: arr(i) = getTokenDefinition("colon", ":") + + 'VarName + i = i + 1: arr(i) = getTokenDefinition("arg", "\$\d+") + i = i + 1: arr(i) = getTokenDefinition("var", "[a-zA-Z][a-zA-Z0-9_]*") + + 'Operators + i = i + 1: arr(i) = getTokenDefinition("propertyAccess", "\.\$") + i = i + 1: arr(i) = getTokenDefinition("methodAccess", "(\.\#)") + i = i + 1: arr(i) = getTokenDefinition("fieldAccess", "\.") + i = i + 1: arr(i) = getTokenDefinition("multiply", "\*") + i = i + 1: arr(i) = getTokenDefinition("divide", "\/") + i = i + 1: arr(i) = getTokenDefinition("power", "\^") + i = i + 1: arr(i) = getTokenDefinition("add", "\+") + i = i + 1: arr(i) = getTokenDefinition("subtract", "\-") + i = i + 1: arr(i) = getTokenDefinition("equal", "\=") + i = i + 1: arr(i) = getTokenDefinition("notEqual", "\<\>") + i = i + 1: arr(i) = getTokenDefinition("greaterThanEqual", "\>\=") + i = i + 1: arr(i) = getTokenDefinition("greaterThan", "\>") + i = i + 1: arr(i) = getTokenDefinition("lessThanEqual", "\<\=") + i = i + 1: arr(i) = getTokenDefinition("lessThan", "\<") + i = i + 1: arr(i) = getTokenDefinition("concatenate", "\&") + + ReDim Preserve arr(1 To i) + + getTokenDefinitions = arr +End Function + +'=========== +' +' PARSING +' +'=========== + +Private Sub parseBlock(ParamArray endToken() As Variant) + Call addScope + Dim size As Integer: size = stackSize + 1 + + ' Consume multiple lines + Dim bLoop As Boolean: bLoop = True + Do + While optConsume("colon"): Wend + Call parseStatement + + For i = LBound(endToken) To UBound(endToken) + If peek(endToken(i)) Then + bLoop = False + End If + Next + Loop While bLoop + + ' Get rid of all extra expression results and declarations + While stackSize > size + Call addOperation(oMerge, , , -1) + Wend + scopeCount = scopeCount - 1 +End Sub + +Private Sub addScope() + scopeCount = scopeCount + 1 + Dim scope As Long: scope = scopeCount + ReDim Preserve scopes(1 To scope) + ReDim Preserve scopesArgCount(1 To scope) + Set scopes(scope) = CreateObject("Scripting.Dictionary") + Set scopesArgCount(scope) = CreateObject("Scripting.Dictionary") +End Sub + +Private Sub parseStatement() + If peek("var") And peek("equal", 2) Then + Call parseAssignment + ElseIf peek("fun") Then + Call parseFunctionDeclaration + Else + Call parseExpression + End If +End Sub + +Private Sub parseExpression() + Call parseLogicPriority1 +End Sub + +Private Sub parseLogicPriority1() 'xor + Call parseLogicPriority2 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("xor") Then + Call parseLogicPriority2 + Call addOperation(oLogic, oXor, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseLogicPriority2() 'or + Call parseLogicPriority3 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("or") Then + Call parseLogicPriority3 + Call addOperation(oLogic, oOr, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseLogicPriority3() 'and + Call parseLogicPriority4 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("and") Then + Call parseLogicPriority4 + Call addOperation(oLogic, oAnd, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseLogicPriority4() 'not + Dim invert As Variant: invert = vbNull + While optConsume("not") + If invert = vbNull Then invert = False + invert = Not invert + Wend + + Call parseComparisonPriority1 + + If invert <> vbNull Then + Call addOperation(oLogic, oNot) + If invert = False Then + Call addOperation(oLogic, oNot) + End If + End If +End Sub + +Private Sub parseComparisonPriority1() '=, <>, <, <=, >, >=, is, Like + Call parseArithmeticPriority1 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("lessThan") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oLt, , -1) + ElseIf optConsume("lessThanEqual") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oLte, , -1) + ElseIf optConsume("greaterThan") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oGt, , -1) + ElseIf optConsume("greaterThanEqual") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oGte, , -1) + ElseIf optConsume("equal") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oEql, , -1) + ElseIf optConsume("notEqual") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oNeq, , -1) + ElseIf optConsume("is") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oIs, , -1) + ElseIf optConsume("like") Then + Call parseArithmeticPriority1 + Call addOperation(oComparison, oLike, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseArithmeticPriority1() '& + Call parseArithmeticPriority2 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("concatenate") Then + Call parseArithmeticPriority2 + Call addOperation(oMisc, oCat, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseArithmeticPriority2() '+, - + Call parseArithmeticPriority3 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("add") Then + Call parseArithmeticPriority3 + Call addOperation(oArithmetic, oAdd, , -1) + ElseIf optConsume("subtract") Then + Call parseArithmeticPriority3 + Call addOperation(oArithmetic, oSub, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + + +Private Sub parseArithmeticPriority3() 'mod + Call parseArithmeticPriority4 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("mod") Then + Call parseArithmeticPriority4 + Call addOperation(oArithmetic, oMod, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseArithmeticPriority4() '*, / + Call parseArithmeticPriority5 + Dim bLoop As Boolean: bLoop = True + Do + If optConsume("multiply") Then + Call parseArithmeticPriority4 + Call addOperation(oArithmetic, oMul, , -1) + ElseIf optConsume("divide") Then + Call parseArithmeticPriority4 + Call addOperation(oArithmetic, oDiv, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseArithmeticPriority5() '+, - (unary) + If optConsume("subtract") Then + Call parseArithmeticPriority5 'recurse + Call addOperation(oArithmetic, oNeg) + ElseIf optConsume("add") Then + Call parseArithmeticPriority5 'recurse + Else + Call parseArithmeticPriority6 + End If +End Sub + +Private Sub parseArithmeticPriority6() '^ + Call parseFlowPriority1 + Do + If optConsume("power") Then + Call parseArithmeticPriority6andahalf '- and + are still identity operators + Call addOperation(oArithmetic, oPow, , -1) + Else + bLoop = False + End If + Loop While bLoop +End Sub + +Private Sub parseArithmeticPriority6andahalf() '+, - (unary) + If optConsume("subtract") Then + Call parseArithmeticPriority6andahalf 'recurse + Call addOperation(oArithmetic, oNeg) + ElseIf optConsume("add") Then + Call parseArithmeticPriority6andahalf 'recurse + Else + Call parseFlowPriority1 + End If +End Sub + +Private Sub parseFlowPriority1() 'if then else + If optConsume("if") Then + Call parseExpression + Dim skipThenJumpIndex As Integer: skipThenJumpIndex = addOperation(oJump, ifFalse, , -1) + + Dim size As Integer: size = stackSize + Call consume("then") + Call parseBlock("else", "end") + Dim skipElseJumpIndex As Integer: skipElseJumpIndex = addOperation(oJump) + operations(skipThenJumpIndex).value = iOperationIndex + stackSize = size + + If optConsume("end") Then + Call addOperation(oPush, , 0, 1) 'Expressions should always return a value + operations(skipElseJumpIndex).value = iOperationIndex + Else + Call consume("else") + Call parseBlock("eof", "rBracket", "end") + operations(skipElseJumpIndex).value = iOperationIndex + + Call optConsume("end") + End If + Else + Call parseValuePriority1 + End If +End Sub + +Private Sub parseValuePriority1() 'numbers, $vars, strings, booleans, (expressions) + + If peek("literalNumber") Then + Call addOperation(oPush, , CDbl(consume("literalNumber")), 1) + ElseIf peek("arg") Then + Call addOperation(oAccess, argument, val(Mid(consume("arg"), 2)), 1) + Call parseManyAccessors + ElseIf peek("literalString") Then + Call parseString + ElseIf peek("literalBoolean") Then + Call addOperation(oPush, , consume("literalBoolean") = "true", 1) + ElseIf peek("var") Then + If Not parseScopeAccess Then + Call parseFunction + End If + Call parseManyAccessors + Else + Call consume("lBracket") + Call parseExpression + Call consume("rBracket") + Call parseManyAccessors + End If +End Sub + +Private Function parseFunction() As Variant + Call addOperation(oPush, , consume("var"), 1) + Dim size As Integer: size = stackSize + Call parseOptParameters + Call addOperation(oFunc) + stackSize = size +End Function + +Private Sub parseManyAccessors() + Dim bLoop As Boolean: bLoop = True + Do + bLoop = False + If parseOptObjectField() Then bLoop = True + If parseOptObjectProperty() Then bLoop = True + If parseOptObjectMethod() Then bLoop = True + Loop While bLoop +End Sub + +Private Function parseOptObjectField() As Boolean + parseOptObjectField = False + If optConsume("fieldAccess") Then + Dim size As Integer: size = stackSize + Call addOperation(oPush, , consume("var"), 1) + Call parseOptParameters + Call addOperation(oObject, oFieldCall) + stackSize = size + parseOptObjectField = True + End If +End Function + +Private Function parseOptObjectProperty() As Boolean + parseOptObjectProperty = False + If optConsume("propertyAccess") Then + Dim size As Integer: size = stackSize + Call addOperation(oPush, , consume("var"), 1) + Call parseOptParameters + Call addOperation(oObject, oPropGet) + stackSize = size + parseOptObjectProperty = True + End If +End Function + +Private Function parseOptObjectMethod() As Boolean + parseOptObjectMethod = False + If optConsume("methodAccess") Then + Dim size As Integer: size = stackSize + Call addOperation(oPush, , consume("var"), 1) + Call parseOptParameters + Call addOperation(oObject, oMethodCall) + stackSize = size + parseOptObjectMethod = True + End If +End Function + +Private Function parseOptParameters() As Boolean + parseOptParameters = False + If optConsume("lBracket") Then + Dim iArgCount As Integer + While Not peek("rBracket") + If iArgCount > 0 Then + Call consume("comma") + End If + Call parseExpression + iArgCount = iArgCount + 1 + Wend + Call consume("rBracket") + If iArgCount > 0 Then + Call addOperation(oPush, , iArgCount, 1) + End If + parseOptParameters = True + End If +End Function + +Private Sub parseString() + Dim sRes As String: sRes = consume("literalString") + sRes = Mid(sRes, 2, Len(sRes) - 2) + sRes = Replace(sRes, """""", """") + Call addOperation(oPush, , sRes, 1) +End Sub + +Private Function parseScopeAccess() As Boolean + If peek("lBracket", 2) Then + parseScopeAccess = parseFunctionAccess() + Else + parseScopeAccess = parseVariableAccess() + End If +End Function + +Private Function parseVariableAccess() As Boolean + parseVariableAccess = False + Dim varName As String: varName = consume("var") + Dim offset As Long: offset = findVariable(varName) + If offset >= 0 Then + parseVariableAccess = True + Call addOperation(oAccess, , 1 + offset, 1) + Else + iTokenIndex = iTokenIndex - 1 ' Revert token consumption + End If +End Function + +Private Sub parseAssignment() + Dim varName As String: varName = consume("var") + Call consume("equal") + Call parseExpression + Dim offset As Long: offset = findVariable(varName) + If offset >= 0 Then + ' If the variable already existed, move the data to that pos on the stack + Call addOperation(oSet, , offset, -1) + Call addOperation(oAccess, , offset, 1) ' To keep a return value + Else + ' If the variable didn't exist yet, treat this stack pos as its source + Call scopes(scopeCount).Add(varName, stackSize) + End If +End Sub + +Private Function findVariable(varName As String) As Long + Dim scope As Long: scope = scopeCount + findVariable = -1 + While scope > 0 + If scopes(scope).Exists(varName) Then + If scope < funcScope Then + Call Throw("Can't access """ & varName & """, functions can unfortunately not access data outside their block") + ElseIf scopesArgCount(scope).Exists(varName) Then + Call Throw("Expected a variable, but found a function for name " & varName) + Else + findVariable = stackSize - scopes(scope).item(varName) + scope = 0 + End If + End If + scope = scope - 1 + Wend +End Function +'todo: +Private Function parseFunctionAccess() As Boolean + parseFunctionAccess = False + Dim funcName As String: funcName = consume("var") + Dim argCount As Long + Dim funcPos As Long: funcPos = findFunction(funcName, argCount) + If funcPos <> -1 Then + parseFunctionAccess = True + Dim returnPosIndex As Integer: returnPosIndex = addOperation(oPush, , , 1) + + ' Consume the arguments + consume ("lBracket") + Dim iArgCount As Integer + While Not peek("rBracket") + If iArgCount > 0 Then Call consume("comma") + Call parseExpression + iArgCount = iArgCount + 1 + Wend + Call consume("rBracket") + If iArgCount <> argCount Then + Call Throw(argCount & " arguments should have been provided to " & funcName & " but only " & iArgCount & " were received") + End If + + ' Add call and return data + Call addOperation(oJump, , funcPos, -iArgCount) 'only -argCount since pushing Result and popping return pos cancel out + operations(returnPosIndex).value = iOperationIndex + Else + iTokenIndex = iTokenIndex - 1 ' Revert token consumption + End If +End Function +'todo: +Private Sub parseFunctionDeclaration() + ' Create a dedicated scope for this funcion + Call addScope + Dim prevFuncScope As Long: prevFuncScope = funcScope + funcScope = scopeCount + + ' Add operation to skip this code in normal operation flow + Dim skipToIndex As Integer: skipToIndex = addOperation(oJump) + + ' Obtain the signature + Call consume("fun") + Dim funcName As String: funcName = consume("var") + Call consume("lBracket") + Dim iArgCount As Integer + While Not peek("rBracket") + If iArgCount > 0 Then Call consume("comma") + Call parseParameterDeclaration + iArgCount = iArgCount + 1 + Wend + Call consume("rBracket") + + ' Register the function + Call scopes(scopeCount - 1).Add(funcName, iOperationIndex) + Call scopesArgCount(scopeCount - 1).Add(funcName, iArgCount) + + ' Obtain the body + Call parseBlock("end") + Call consume("end") + While iArgCount > 0 + Call addOperation(oMerge, , , -1) + iArgCount = iArgCount - 1 + Wend + Call addOperation(oReturn, withValue, , -1) + operations(skipToIndex).value = iOperationIndex + + ' Reset the scope + scopeCount = scopeCount - 1 + funcScope = prevFuncScope +End Sub +'todo: +Private Sub parseParameterDeclaration() + Dim varName As String: varName = consume("var") + Dim offset As Long: offset = findVariable(varName) + If offset >= 0 Then + Call Throw("You can't declare multiple parameters with the same name") + Else + ' Reserve a spot for this parameter, it will be pushed by the caller + stackSize = stackSize + 1 + Call scopes(scopeCount).Add(varName, stackSize) + End If +End Sub + +Private Function findFunction(varName As String, Optional ByRef argCount As Long) As Long + Dim scope As Long: scope = scopeCount + findFunction = -1 + While scope > 0 + If scopes(scope).Exists(varName) Then + If Not scopesArgCount(scope).Exists(varName) Then + Call Throw("Expected a function, but found a variable for name " & varName) + Else + findFunction = scopes(scope).item(varName) + argCount = scopesArgCount(scope).item(varName) + scope = 0 + End If + End If + scope = scope - 1 + Wend +End Function + + +'============== +' +' EVALUATION +' +'============== + +'Evaluates the given list of operations +'@param {Operation()} operations The operations to evaluate +'@returns {Variant} The result of the operations +Private Function evaluate(ByRef ops() As Operation, ByVal vLastArgs As Variant) As Variant + Dim stack() As Variant + ReDim stack(0 To 5) + Dim stackPtr As Long: stackPtr = 0 + + Dim op As Operation + Dim v1 As Variant + Dim v2 As Variant + Dim v3 As Variant + Dim opIndex As Long: opIndex = 0 + Dim opCount As Long: opCount = UBound(ops) + + 'If result is in performance cache then return it immediately + If bUsePerformanceCache Then + Dim sPerformanceCacheID As String: sPerformanceCacheID = getPerformanceCacheID(vLastArgs) + If pPerformanceCache.Exists(sPerformanceCacheID) Then + Call CopyVariant(evaluate, pPerformanceCache(sPerformanceCacheID)) + Exit Function + End If + End If + + 'Evaluate operations to identify result + While opIndex <= opCount + op = ops(opIndex) + opIndex = opIndex + 1 + Select Case op.Type + Case iType.oPush + Call pushV(stack, stackPtr, op.value) + 'Arithmetic + Case iType.oArithmetic + v2 = popV(stack, stackPtr) + Select Case op.subType + Case ISubType.oAdd + v1 = popV(stack, stackPtr) + v3 = v1 + v2 + Case ISubType.oSub + v1 = popV(stack, stackPtr) + v3 = v1 - v2 + Case ISubType.oMul + v1 = popV(stack, stackPtr) + v3 = v1 * v2 + Case ISubType.oDiv + v1 = popV(stack, stackPtr) + v3 = v1 / v2 + Case ISubType.oPow + v1 = popV(stack, stackPtr) + v3 = v1 ^ v2 + Case ISubType.oMod + v1 = popV(stack, stackPtr) + v3 = v1 Mod v2 + Case ISubType.oNeg + v3 = -v2 + Case Else + v3 = Empty + End Select + Call pushV(stack, stackPtr, v3) + 'Comparison + Case iType.oComparison + Call CopyVariant(v2, popV(stack, stackPtr)) + Call CopyVariant(v1, popV(stack, stackPtr)) + If varType(v1) = vbError Or varType(v2) = vbError Then + v3 = False + Else + Select Case op.subType + Case ISubType.oEql + v3 = v1 = v2 + Case ISubType.oNeq + v3 = v1 <> v2 + Case ISubType.oGt + v3 = v1 > v2 + Case ISubType.oGte + v3 = v1 >= v2 + Case ISubType.oLt + v3 = v1 < v2 + Case ISubType.oLte + v3 = v1 <= v2 + Case ISubType.oLike + v3 = v1 Like v2 + Case ISubType.oIs + v3 = v1 Is v2 + Case Else + v3 = Empty + End Select + End If + Call pushV(stack, stackPtr, v3) + 'Logic + Case iType.oLogic + v2 = popV(stack, stackPtr) + Select Case op.subType + Case ISubType.oAnd + v1 = popV(stack, stackPtr) + v3 = v1 And v2 + Case ISubType.oOr + v1 = popV(stack, stackPtr) + v3 = v1 Or v2 + Case ISubType.oNot + v3 = Not v2 + Case ISubType.oXor + v1 = popV(stack, stackPtr) + v3 = v1 Xor v2 + Case Else + v3 = Empty + End Select + Call pushV(stack, stackPtr, v3) + 'Object + Case iType.oObject + Call objectCaller(stack, stackPtr, op) + 'Func + Case iType.oFunc + Dim args() As Variant + args = getArgs(stack, stackPtr) + v1 = popV(stack, stackPtr) + Call pushV(stack, stackPtr, evaluateFunc(v1, args)) + 'Misc + Case iType.oMisc + v2 = popV(stack, stackPtr) + v1 = popV(stack, stackPtr) + Select Case op.subType + Case ISubType.oCat + v3 = v1 & v2 + Case Else + v3 = Empty + End Select + Call pushV(stack, stackPtr, v3) + 'Variable + Case iType.oAccess + Select Case op.subType + Case ISubType.argument + Dim iArgIndex As Long: iArgIndex = op.value + LBound(vLastArgs) - 1 + If iArgIndex <= UBound(vLastArgs) Then + Call pushV(stack, stackPtr, vLastArgs(iArgIndex)) + Else + Call Throw("Argument " & iArgIndex & " not supplied to Lambda.") + End If + Case Else + 'HACK: bug where if stack(stackPtr-op.value) was an object, then array will become locked. Array locking occurs by compiler to try to protect + 'instances when re-allocation would move the array, and thus corrupt the pointers. By copying the variant we redivert the compiler's efforts, + 'but we might actually open ourselves to errors... @issue + Dim vAccessVar: Call CopyVariant(vAccessVar, stack(stackPtr - op.value)) + Call pushV(stack, stackPtr, vAccessVar) + End Select + Case iType.oSet + v1 = popV(stack, stackPtr) + stack(stackPtr - op.value) = v1 + 'Flow + Case iType.oJump + Select Case op.subType + Case ISubType.ifTrue + v1 = popV(stack, stackPtr) + If v1 Then + opIndex = op.value + End If + Case ISubType.ifFalse + v1 = popV(stack, stackPtr) + If Not v1 Then + opIndex = op.value + End If + Case Else + opIndex = op.value + End Select + Case iType.oReturn + Select Case op.subType + Case ISubType.withValue + Call CopyVariant(v1, popV(stack, stackPtr)) + opIndex = stack(stackPtr - 1) + Call CopyVariant(stack(stackPtr - 1), v1) + Case Else + opIndex = popV(stack, stackPtr) + End Select + 'Data + Case iType.oMerge + Call CopyVariant(v1, popV(stack, stackPtr)) + Call CopyVariant(stack(stackPtr - 1), v1) + Case iType.oPop + Call popV(stack, stackPtr) + Case Else + 'End loop - This occurs when opIndex > opCount + opIndex = opCount + 1 + End Select + Wend + + 'Add result to performance cache + If bUsePerformanceCache Then + If isObject(stack(0)) Then + Set pPerformanceCache(sPerformanceCacheID) = stack(0) + Else + Let pPerformanceCache(sPerformanceCacheID) = stack(0) + End If + End If + + Call CopyVariant(evaluate, stack(0)) +End Function + +'Retrieves the arguments from the stack +'@param {ByRef Variant()} stack The stack to get the data from and add the result to +'@param {ByRef Long} stackPtr The pointer that indicates the position of the top of the stack +'@returns {Variant()} The args list +Private Function getArgs(ByRef stack() As Variant, ByRef stackPtr As Long) As Variant + Dim argCount As Variant: argCount = stack(stackPtr - 1) + Dim args() As Variant + If varType(argCount) = vbString Then + 'If no argument count is specified, there are no arguments + argCount = 0 + args = Array() + Else + 'If an argument count is provided, extract all arguments into an array + Call popV(stack, stackPtr) + ReDim args(1 To argCount) + + 'Arguments are held on the stack in order, which means that we need to fill the array in reverse order. + For i = argCount To 1 Step -1 + Call CopyVariant(args(i), popV(stack, stackPtr)) + Next + End If + + getArgs = args +End Function + +'Calls an object method/setter/getter/letter +'@param {ByRef Variant()} stack The stack to get the data from and add the result to +'@param {ByRef Long} stackPtr The pointer that indicates the position of the top of the stack +'@param {ByRef Operation} op The operation to execute +Private Sub objectCaller(ByRef stack() As Variant, ByRef stackPtr As Long, ByRef op As Operation) + 'Get the name and arguments + Dim args() As Variant: args = getArgs(stack, stackPtr) + Dim funcName As Variant: funcName = popV(stack, stackPtr) + + 'Get caller type + Dim callerType As VbCallType + Select Case op.subType + Case ISubType.oFieldCall: callerType = VbGet Or VbMethod + Case ISubType.oPropGet: callerType = VbGet + Case ISubType.oMethodCall: callerType = VbMethod + Case ISubType.oPropLet: callerType = VbLet + Case ISubType.oPropSet: callerType = VbSet + End Select + + 'Call rtcCallByName + Dim obj As Object + Set obj = popV(stack, stackPtr) + Call pushV(stack, stackPtr, stdCallByName(obj, funcName, callerType, args)) +End Sub + +'Calls an object method/setter/getter/letter. Treats dictionary properties as direct object properties, I.E. `A.B` ==> `A.item("B")` +'@param {ByRef Object} - The object to call +'@param {ByVal String} - The method name to call +'@param {ByVal VbCallType} - The property/method call type +'@param {ByVal Variant()} - An array of arguments. This function supports up to 30 arguments, akin to Application.Run +'@returns Variant - The return value of the called function +Public Function stdCallByName(ByRef obj As Object, ByVal funcName As String, ByVal callerType As VbCallType, ByRef args() As Variant) As Variant + 'If Dictionary and + If TypeName(obj) = "Dictionary" Then + Select Case funcName + Case "add", "exists", "items", "keys", "remove", "removeall", "comparemode", "count", "item", "key" + 'These methods already exist on dictionary, do not override + Case Else + 'Call DictionaryInstance.Item(funcName) only if funcName exists on the item + If obj.Exists(funcName) Then + 'TODO: Make this work for callerType.VbLet + Call CopyVariant(stdCallByName, obj.item(funcName)) + Exit Function + End If + End Select + End If + + 'Call CallByName from DLL or + #If Mac Then + Call CopyVariant(stdCallByName, macCallByName(obj, funcName, callerType, args)) + #Else + 'TODO: Better error handling (property or method doesn't exist on object with type ) + On Error GoTo ErrorInRTCCallByName + Call CopyVariant(stdCallByName, rtcCallByName(obj, StrPtr(funcName), callerType, args, &H409)) + #End If + Exit Function +ErrorInRTCCallByName: + 'HACK: Rarely objects which are poorly implemented might throw missing member errors. This can for instance happen with RecordSet. This try loop is an attempt to catch this + Dim iTry As Long: iTry = iTry + 1 + If iTry < 5 Then + Dim sCallerTypeName As String + Select Case callerType + Case VbGet Or VbMethod: sCallerTypeName = "Property or Method " + Case VbGet: sCallerTypeName = "Property " + Case VbMethod: sCallerTypeName = "Method " + End Select + Err.Raise Err.Number, "", sCallerTypeName & funcName & " doesn't exist on object with type " & TypeName(obj) + Resume + Else + Resume + End If +End Function + +'Evaluates the built in standard functions +'@param {String} sFuncName The name of the function to invoke +'@param {Variant} args() The arguments +'@returns The result +Private Function evaluateFunc(ByVal sFuncName As String, ByVal args As Variant) As Variant + Dim iArgStart As Long: iArgStart = LBound(args) + If TypeName(oFunctExt) = "Dictionary" Then + If oFunctExt.Exists(sFuncName) Then + Dim vInjectedVar As Variant + Call CopyVariant(vInjectedVar, oFunctExt(sFuncName)) + If TypeOf vInjectedVar Is stdICallable Then + Call CopyVariant(evaluateFunc, oFunctExt(sFuncName).RunEx(args)) + Else + Call CopyVariant(evaluateFunc, vInjectedVar) + End If + Exit Function + End If + End If + + Select Case LCase(sFuncName) + 'Useful OOP constants + Case "thisworkbook": If isObject(ThisWorkbook) Then Set evaluateFunc = ThisWorkbook + Case "application": If isObject(Application) Then Set evaluateFunc = Application + + 'Data structures + Case "dict": + Dim oRetDict As Object: Set oRetDict = CreateObject("Scripting.Dictionary") + For i = iArgStart To UBound(args) Step 2 + Call oRetDict.Add(args(i), args(i + 1)) + Next + Set evaluateFunc = oRetDict + + 'MATH: + '----- + Case "abs": evaluateFunc = VBA.Math.Abs(args(iArgStart)) + Case "int": evaluateFunc = VBA.Int(args(iArgStart)) + Case "fix": evaluateFunc = VBA.Fix(args(iArgStart)) + Case "exp": evaluateFunc = VBA.Math.Exp(args(iArgStart)) + Case "log": evaluateFunc = VBA.Math.Log(args(iArgStart)) + Case "sqr": evaluateFunc = VBA.Math.Sqr(args(iArgStart)) + Case "sgn": evaluateFunc = VBA.Math.Sgn(args(iArgStart)) + Case "rnd": evaluateFunc = VBA.Math.Rnd(args(iArgStart)) + + 'Trigonometry + Case "cos": evaluateFunc = VBA.Math.Cos(args(iArgStart)) + Case "sin": evaluateFunc = VBA.Math.Sin(args(iArgStart)) + Case "tan": evaluateFunc = VBA.Math.Tan(args(iArgStart)) + Case "atn": evaluateFunc = VBA.Math.Atn(args(iArgStart)) + Case "asin": evaluateFunc = VBA.Math.Atn(args(iArgStart) / VBA.Math.Sqr(-1 * args(iArgStart) * args(iArgStart) + 1)) + Case "acos": evaluateFunc = VBA.Math.Atn(-1 * args(iArgStart) / VBA.Math.Sqr(-1 * args(iArgStart) * args(iArgStart) + 1)) + 2 * Atn(1) + + 'VBA Constants: + Case "vbcrlf": evaluateFunc = vbCrLf + Case "vbcr": evaluateFunc = vbCr + Case "vblf": evaluateFunc = vbLf + Case "vbnewline": evaluateFunc = vbNewLine + Case "vbnullchar": evaluateFunc = vbNullChar + Case "vbnullstring": evaluateFunc = vbNullString + Case "vbobjecterror": evaluateFunc = vbObjectError + Case "vbtab": evaluateFunc = vbTab + Case "vbback": evaluateFunc = vbBack + Case "vbformfeed": evaluateFunc = vbFormFeed + Case "vbverticaltab": evaluateFunc = vbVerticalTab + Case "null": evaluateFunc = Null + Case "nothing": Set evaluateFunc = Nothing + Case "empty": evaluateFunc = Empty + Case "missing": evaluateFunc = GetMissing() + + 'VBA Structure + Case "array": evaluateFunc = args + 'TODO: Case "callbyname": evaluateFunc = CallByName(args(iArgStart)) + Case "createobject" + Select Case UBound(args) + Case iArgStart + Set evaluateFunc = CreateObject(args(iArgStart)) + Case iArgStart + 1 + Set evaluateFunc = CreateObject(args(iArgStart), args(iArgStart + 1)) + End Select + Case "getobject" + Select Case UBound(args) + Case iArgStart + Set evaluateFunc = GetObject(args(iArgStart)) + Case iArgStart + 1 + Set evaluateFunc = GetObject(args(iArgStart), args(iArgStart + 1)) + End Select + Case "iff" + If CBool(args(iArgStart)) Then + evaluateFunc = args(iArgStart + 1) + Else + evaluateFunc = args(iArgStart + 2) + End If + Case "typename" + evaluateFunc = TypeName(args(iArgStart)) + + 'VBA Casting + Case "cbool": evaluateFunc = VBA.Conversion.CBool(args(iArgStart)) + Case "cbyte": evaluateFunc = VBA.Conversion.CByte(args(iArgStart)) + Case "ccur": evaluateFunc = VBA.Conversion.CCur(args(iArgStart)) + Case "cdate": evaluateFunc = VBA.Conversion.CDate(args(iArgStart)) + Case "csng": evaluateFunc = VBA.Conversion.CSng(args(iArgStart)) + Case "cdbl": evaluateFunc = VBA.Conversion.CDbl(args(iArgStart)) + Case "cint": evaluateFunc = VBA.Conversion.CInt(args(iArgStart)) + Case "clng": evaluateFunc = VBA.Conversion.CLng(args(iArgStart)) + Case "cstr": evaluateFunc = VBA.Conversion.CStr(args(iArgStart)) + Case "cvar": evaluateFunc = VBA.Conversion.CVar(args(iArgStart)) + Case "cverr": evaluateFunc = VBA.Conversion.CVErr(args(iArgStart)) + + 'Conversion + Case "asc": evaluateFunc = VBA.Asc(args(iArgStart)) + Case "chr": evaluateFunc = VBA.Chr(args(iArgStart)) + + Case "format" + Select Case UBound(args) + Case iArgStart + evaluateFunc = Format(args(iArgStart)) + Case iArgStart + 1 + evaluateFunc = Format(args(iArgStart), args(iArgStart + 1)) + Case iArgStart + 2 + evaluateFunc = Format(args(iArgStart), args(iArgStart + 1), args(iArgStart + 2)) + Case iArgStart + 3 + evaluateFunc = Format(args(iArgStart), args(iArgStart + 1), args(iArgStart + 2), args(iArgStart + 3)) + End Select + Case "hex": evaluateFunc = VBA.Conversion.Hex(args(iArgStart)) + Case "oct": evaluateFunc = VBA.Conversion.Oct(args(iArgStart)) + Case "str": evaluateFunc = VBA.Conversion.Str(args(iArgStart)) + Case "val": evaluateFunc = VBA.Conversion.val(args(iArgStart)) + + 'String functions + Case "trim": evaluateFunc = VBA.Trim(args(iArgStart)) + Case "lcase": evaluateFunc = VBA.LCase(args(iArgStart)) + Case "ucase": evaluateFunc = VBA.UCase(args(iArgStart)) + Case "right": evaluateFunc = VBA.right(args(iArgStart), args(iArgStart + 1)) + Case "left": evaluateFunc = VBA.Left(args(iArgStart), args(iArgStart + 1)) + Case "len": evaluateFunc = VBA.Len(args(iArgStart)) + + Case "mid" + Select Case UBound(args) + Case iArgStart + 1 + evaluateFunc = VBA.Mid(args(iArgStart), args(iArgStart + 1)) + Case iArgStart + 2 + evaluateFunc = VBA.Mid(args(iArgStart), args(iArgStart + 1), args(iArgStart + 2)) + End Select + 'Misc + Case "now": evaluateFunc = VBA.DateTime.Now() + Case "switch" + 'TODO: Switch caching and use of dictionary would be good here + For i = iArgStart + 1 To UBound(args) Step 2 + If i + 1 > UBound(args) Then + Call CopyVariant(evaluateFunc, args(i)) + Exit For + Else + If isObject(args(iArgStart)) And isObject(args(i)) Then + If args(iArgStart) Is args(i) Then + Set evaluateFunc = args(i + 1) + Exit For + End If + ElseIf (Not isObject(args(iArgStart))) And (Not isObject(args(i))) Then + If args(iArgStart) = args(i) Then + evaluateFunc = args(i + 1) + Exit For + End If + End If + End If + Next + Case "any" + evaluateFunc = False + 'Detect if comparee is an object or a value + If isObject(args(iArgStart)) Then + For i = iArgStart + 1 To UBound(args) + If isObject(args(i)) Then + If args(iArgStart) Is args(i) Then + evaluateFunc = True + Exit For + End If + End If + Next + Else + For i = iArgStart + 1 To UBound(args) + If Not isObject(args(i)) Then + If args(iArgStart) = args(i) Then + evaluateFunc = True + Exit For + End If + End If + Next + End If + Case "eval": evaluateFunc = stdLambda.Create(args(iArgStart)).Run() + Case "lambda": Set evaluateFunc = stdLambda.Create(args(iArgStart)) + Case "isnumeric": evaluateFunc = isNumeric(args(iArgStart)) + Case "isobject": evaluateFunc = isObject(args(iArgStart)) + Case Else + Call Throw("No such function: " & sFuncName) + End Select +End Function + +'========================== +' +' General helper methods +' +'========================== + +'Class initialisation +Private Sub Class_Initialize() + 'If this is stdLambda predeclared class, ensure that oFuncExt is defined. + If Me Is stdLambda Then Set oFuncExt = CreateObject("Scripting.Dictionary") +End Sub + +'------------ +'tokenisation +'------------ + +'Tokenise the input string +'@param {string} sInput String to tokenise +'@return {token[]} A list of Token structs +Private Function Tokenise(ByVal sInput As String) As token() + Dim defs() As TokenDefinition + defs = getTokenDefinitions() + + Dim tokens() As token, iTokenDef As Long + ReDim tokens(1 To 1) + + Dim sInputOld As String + sInputOld = sInput + + Dim iNumTokens As Long + iNumTokens = 0 + While Len(sInput) > 0 + Dim bMatched As Boolean + bMatched = False + + For iTokenDef = 1 To UBound(defs) + 'Test match, if matched then add token + If defs(iTokenDef).RegexObj.test(sInput) Then + 'Get match details + Dim oMatch As Object: Set oMatch = defs(iTokenDef).RegexObj.Execute(sInput) + + 'Create new token + iNumTokens = iNumTokens + 1 + ReDim Preserve tokens(1 To iNumTokens) + + 'Tokenise + tokens(iNumTokens).Type = defs(iTokenDef) + tokens(iNumTokens).value = oMatch(0) + + 'Trim string to unmatched range + sInput = Mid(sInput, Len(oMatch(0)) + 1) + + 'Flag that a match was made + bMatched = True + Exit For + End If + Next + + 'If no match made then syntax error + If Not bMatched Then + Call Throw("Syntax Error unexpected character """ & Mid(sInput, 1, 1) & """") + End If + Wend + + 'Add eof token + ReDim Preserve tokens(1 To iNumTokens + 1) + tokens(iNumTokens + 1).Type.name = "eof" + + Tokenise = removeTokens(tokens, "space") +End Function + +'Obtains a TokenDefinition from input params +'@param {ByVal String} The name of the token +'@param {ByVal String} The regex pattern to match durin tokenisation +'@param {ByVal Boolean?=True} Should this token ignoreCase? +'@param {ByVal Boolean?=False} Is this token a keyword? +'@returns {TokenDefinition} The definition of the token +Private Function getTokenDefinition(ByVal sName As String, ByVal sRegex As String, Optional ByVal ignoreCase As Boolean = True, Optional ByVal isKeyword As Boolean = False) As TokenDefinition + getTokenDefinition.name = sName + getTokenDefinition.Regex = sRegex & IIf(isKeyword, "\b", "") + Set getTokenDefinition.RegexObj = CreateObject("VBScript.Regexp") + getTokenDefinition.RegexObj.Pattern = "^(?:" & sRegex & IIf(isKeyword, "\b", "") & ")" + getTokenDefinition.RegexObj.ignoreCase = ignoreCase +End Function + +'Copies one variant to a destination +'@param {ByRef Token()} tokens Tokens to remove the specified type from +'@param {string} sRemoveType Token type to remove. +'@returns {Token()} The modified token array. +Private Function removeTokens(ByRef tokens() As token, ByVal sRemoveType As String) As token() + Dim iCountRemoved As Long: iCountRemoved = 0 + Dim iToken As Long + For iToken = LBound(tokens) To UBound(tokens) + If tokens(iToken).Type.name <> sRemoveType Then + tokens(iToken - iCountRemoved) = tokens(iToken) + Else + iCountRemoved = iCountRemoved + 1 + End If + Next + ReDim Preserve tokens(LBound(tokens) To (UBound(tokens) - iCountRemoved)) + removeTokens = tokens +End Function + +'------- +'parsing +'------- + +'Shifts the Tokens array (uses an index) +'@returns {token} The token at the tokenIndex +Private Function ShiftTokens() As token + If iTokenIndex = 0 Then iTokenIndex = 1 + + 'Get next token + ShiftTokens = tokens(iTokenIndex) + + 'Increment token index + iTokenIndex = iTokenIndex + 1 +End Function + +' Consumes a token +' @param {string} token The token type name to consume +' @throws If the expected token wasn't found +' @returns {string} The value of the token +Private Function consume(ByVal sType As String) As String + Dim firstToken As token + firstToken = ShiftTokens() + If firstToken.Type.name <> sType Then + Call Throw("Unexpected token, found: " & firstToken.Type.name & " but expected: " & sType) + Else + consume = firstToken.value + End If +End Function + +'Checks whether the token at iTokenIndex is of the given type +'@param {string} token The token that is expected +'@param {long} offset The number of tokens to look into the future, defaults to 1 +'@returns {boolean} Whether the expected token was found +Private Function peek(ByVal sTokenType As String, Optional offset As Long = 1) As Boolean + If iTokenIndex = 0 Then iTokenIndex = 1 + If iTokenIndex + offset - 1 <= UBound(tokens) Then + peek = tokens(iTokenIndex + offset - 1).Type.name = sTokenType + Else + peek = False + End If +End Function + +' Combines peek and consume, consuming a token only if matched, without throwing an error if not +' @param {string} token The token that is expected +' @returns {vbNullString|string} Whether the expected token was found +Private Function optConsume(ByVal sTokenType As String) As Boolean + Dim matched As Boolean: matched = peek(sTokenType) + If matched Then + Call consume(sTokenType) + End If + optConsume = matched +End Function + +'Checks the value of the passed parameter, to check if it is the unique constant +'@param {Variant} test The value to test. May be an object or literal value +'@returns {Boolean} True if the value is the unique constant, otherwise false +Private Function isUniqueConst(ByRef test As Variant) As Boolean + If Not isObject(test) Then + If varType(test) = vbString Then + If test = UniqueConst Then + isUniqueConst = True + Exit Function + End If + End If + End If + isUniqueConst = False +End Function + +'Adds an operation to the instance operations list +'@param {IType} kType The main type of the operation +'@param {ISubType} subType The sub type of the operation +'@param {Variant} value The value associated with the operation +'@param {Integer} stackDelta The effect this has on the stack size (increasing or decreasing it) +'@returns {Integer} The index of the created operation +Private Function addOperation(kType As iType, Optional subType As ISubType, Optional value As Variant, Optional stackDelta As Integer) As Integer + If iOperationIndex = 0 Then + ReDim Preserve operations(0 To 1) + Else + Dim size As Long: size = UBound(operations) + If iOperationIndex > size Then + ReDim Preserve operations(0 To size * 2) + End If + End If + + With operations(iOperationIndex) + .Type = kType + .subType = subType + Call CopyVariant(.value, value) + End With + addOperation = iOperationIndex + stackSize = stackSize + stackDelta + + iOperationIndex = iOperationIndex + 1 +End Function + +'Resizes the operations list so there are no more empty operations +Private Sub finishOperations() + ReDim Preserve operations(0 To iOperationIndex) +End Sub + +'---------- +'evaluation +'---------- + +Private Sub pushV(ByRef stack() As Variant, ByRef index As Long, ByVal item As Variant) + Dim size As Long: size = UBound(stack) + If index > size Then + ReDim Preserve stack(0 To size * 2) + End If + If isObject(item) Then + Set stack(index) = item + Else + stack(index) = item + End If + index = index + 1 +End Sub + +Private Function popV(ByRef stack() As Variant, ByRef index As Variant) As Variant + Dim size As Long: size = UBound(stack) + If index < size / 3 And index > minStackSize Then + ReDim Preserve stack(0 To CLng(size / 2)) + End If + index = index - 1 + If isObject(stack(index)) Then + Set popV = stack(index) + Else + popV = stack(index) + End If + #If devMode Then + stack(index) = Empty + #End If +End Function + +'Serializes the argument array passed to a string. +'@param {ByRef Variant()} Arguments to serialize +'@returns {String} Serialized representation of the arguments. +'@remark Objects cannot be split into their components and thus are cached as a conglomerate of type and pointer (e.g. Dictionary<12341234123>). +'@TODO: Potentially use [StgSerializePropVariant ](https://docs.microsoft.com/en-us/windows/win32/api/propvarutil/nf-propvarutil-stgserializepropvariant) as this'd be more optimal +'@example +' Debug.Print getPerformanceCacheID(Array())="" +' Debug.Print getPerformanceCacheID(Array(Array(1, 2, Null), "yop", Empty, "", Nothing, New Collection, DateSerial(2020, 1, 1), False, True)) = "Array[1;2;null;];""yop"";empty;"""";Nothing;Collection<1720260481920>;01/01/2020;False;True;" +'returns +' True +' True +Private Function getPerformanceCacheID(ByRef Arguments As Variant) As String + Dim Length As Long: Length = UBound(Arguments) - LBound(Arguments) + 1 + If Length > 0 Then + Dim sSerialized As String: sSerialized = "" + For i = LBound(Arguments) To UBound(Arguments) + Select Case varType(Arguments(i)) + Case vbBoolean, vbByte, vbInteger, vbLong, vbLongLong, vbCurrency, vbDate, vbDecimal, vbDouble, vbSingle + sSerialized = sSerialized & Arguments(i) & ";" + Case vbString + sSerialized = sSerialized & """" & Arguments(i) & """;" + Case vbObject, vbDataObject + If Arguments(i) Is Nothing Then + sSerialized = sSerialized & "Nothing;" + Else + sSerialized = sSerialized & TypeName(Arguments(i)) & "<" & ObjPtr(Arguments(i)) & ">;" + End If + Case vbEmpty + sSerialized = sSerialized & "empty;" + Case vbNull + sSerialized = sSerialized & "null;" + Case vbError + sSerialized = sSerialized & "error;" + Case Else + If CBool(varType(Arguments(i)) And vbArray) Then + sSerialized = sSerialized & "Array[" & getPerformanceCacheID(Arguments(i)) & "];" + Else + sSerialized = sSerialized & "Unknown;" + End If + End Select + Next + End If + getPerformanceCacheID = sSerialized +End Function + +'------- +'general +'------- + +'Used to obtain missing +'@Param {Variant} The value to be returned - Please do not populate this parameter. +'@returns {Missing} Missing value +Private Function GetMissing(Optional arg As Variant) As Variant + GetMissing = arg +End Function + +'Copies one variant to a destination +'@param {ByRef Variant} dest Destination to copy variant to +'@param {Variant} value Source to copy variant from. +'@perf This appears to be a faster variant of "oleaut32.dll\VariantCopy" + it's multi-platform +Private Sub CopyVariant(ByRef dest As Variant, ByVal value As Variant) + If isObject(value) Then + Set dest = value + Else + Let dest = value + End If +End Sub + + +'TODO: Better error handling +'Throws an error +'@param {string} The error message to be thrown +'@returns {void} +Private Sub Throw(ByVal sMessage As String) + Err.Raise 1, "stdLambda", sMessage, vbCritical + End +End Sub + + +'Used by Bind() for binding arguments ontop of BoundArgs and binding bound args to passed arguments +'@param {Variant()} The 1st array which will +'@param {Variant()} The 2nd array which will be concatenated after the 1st +'@complexity O(1) +Private Function ConcatArrays(ByVal Arr1 As Variant, ByVal Arr2 As Variant) As Variant + Dim ub1 As Long: ub1 = UBound(Arr1) + Dim lb1 As Long: lb1 = LBound(Arr1) + Dim ub2 As Long: ub2 = UBound(Arr2) + Dim lb2 As Long: lb2 = LBound(Arr2) + Dim iub As Long: iub = ub1 + ub2 - lb2 + 1 + + If iub > -1 Then + Dim v() As Variant + ReDim v(lb1 To iub) + + + Dim i As Long + For i = LBound(v) To UBound(v) + If i <= ub1 Then + Call CopyVariant(v(i), Arr1(i)) + Else + Call CopyVariant(v(i), Arr2(i - ub1 - 1 + lb2)) + End If + Next + ConcatArrays = v + Else + ConcatArrays = Array() + End If +End Function + + + +'---------- +'evaluation Mac +'---------- + +'Reimplementation of rtcCallByName() but for Mac OS +'@param {ByRef Object} - The object to call +'@param {ByVal String} - The method name to call +'@param {ByVal VbCallType} - The property/method call type +'@param {ByVal Variant()} - An array of arguments. This function supports up to 30 arguments, akin to Application.Run +'@returns Variant - The return value of the called function +Private Function macCallByName(ByRef obj As Object, ByVal funcName As String, ByVal callerType As VbCallType, ByVal args As Variant) As Variant + 'Get currentLength + Dim currentLength As Integer: currentLength = UBound(args) - LBound(args) + 1 + Dim i As Long: i = LBound(args) + + 'Cant use same trick as in stdCallback, as it seems CallByName doesn't support the Missing value... So have to do it this way... + 'Will go up to 30 as per Application.Run() Also seems that you can't pass args array directly to CallByName() because it causes an Overflow error, + 'instead we need to convert the args to vars first... Yes this doesn't look at all pretty, but at least it's compartmentalised to the end of the code... + Dim a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29 + If currentLength - 1 >= 0 Then Call CopyVariant(a0, args(i + 0)) Else GoTo macJmpCall + If currentLength - 1 >= 1 Then Call CopyVariant(a1, args(i + 1)) Else GoTo macJmpCall + If currentLength - 1 >= 2 Then Call CopyVariant(a2, args(i + 2)) Else GoTo macJmpCall + If currentLength - 1 >= 3 Then Call CopyVariant(a3, args(i + 3)) Else GoTo macJmpCall + If currentLength - 1 >= 4 Then Call CopyVariant(a4, args(i + 4)) Else GoTo macJmpCall + If currentLength - 1 >= 5 Then Call CopyVariant(a5, args(i + 5)) Else GoTo macJmpCall + If currentLength - 1 >= 6 Then Call CopyVariant(a6, args(i + 6)) Else GoTo macJmpCall + If currentLength - 1 >= 7 Then Call CopyVariant(a7, args(i + 7)) Else GoTo macJmpCall + If currentLength - 1 >= 8 Then Call CopyVariant(a8, args(i + 8)) Else GoTo macJmpCall + If currentLength - 1 >= 9 Then Call CopyVariant(a9, args(i + 9)) Else GoTo macJmpCall + If currentLength - 1 >= 10 Then Call CopyVariant(a10, args(i + 10)) Else GoTo macJmpCall + If currentLength - 1 >= 11 Then Call CopyVariant(a11, args(i + 11)) Else GoTo macJmpCall + If currentLength - 1 >= 12 Then Call CopyVariant(a12, args(i + 12)) Else GoTo macJmpCall + If currentLength - 1 >= 13 Then Call CopyVariant(a13, args(i + 13)) Else GoTo macJmpCall + If currentLength - 1 >= 14 Then Call CopyVariant(a14, args(i + 14)) Else GoTo macJmpCall + If currentLength - 1 >= 15 Then Call CopyVariant(a15, args(i + 15)) Else GoTo macJmpCall + If currentLength - 1 >= 16 Then Call CopyVariant(a16, args(i + 16)) Else GoTo macJmpCall + If currentLength - 1 >= 17 Then Call CopyVariant(a17, args(i + 17)) Else GoTo macJmpCall + If currentLength - 1 >= 18 Then Call CopyVariant(a18, args(i + 18)) Else GoTo macJmpCall + If currentLength - 1 >= 19 Then Call CopyVariant(a19, args(i + 19)) Else GoTo macJmpCall + If currentLength - 1 >= 20 Then Call CopyVariant(a20, args(i + 20)) Else GoTo macJmpCall + If currentLength - 1 >= 21 Then Call CopyVariant(a21, args(i + 21)) Else GoTo macJmpCall + If currentLength - 1 >= 22 Then Call CopyVariant(a22, args(i + 22)) Else GoTo macJmpCall + If currentLength - 1 >= 23 Then Call CopyVariant(a23, args(i + 23)) Else GoTo macJmpCall + If currentLength - 1 >= 24 Then Call CopyVariant(a24, args(i + 24)) Else GoTo macJmpCall + If currentLength - 1 >= 25 Then Call CopyVariant(a25, args(i + 25)) Else GoTo macJmpCall + If currentLength - 1 >= 26 Then Call CopyVariant(a26, args(i + 26)) Else GoTo macJmpCall + If currentLength - 1 >= 27 Then Call CopyVariant(a27, args(i + 27)) Else GoTo macJmpCall + If currentLength - 1 >= 28 Then Call CopyVariant(a28, args(i + 28)) Else GoTo macJmpCall + If currentLength - 1 >= 29 Then Call CopyVariant(a29, args(i + 29)) Else GoTo macJmpCall + +macJmpCall: + Select Case currentLength + Case 0: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType)) + Case 1: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0)) + Case 2: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1)) + Case 3: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2)) + Case 4: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3)) + Case 5: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4)) + Case 6: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5)) + Case 7: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6)) + Case 8: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7)) + Case 9: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8)) + Case 10: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)) + Case 11: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)) + Case 12: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11)) + Case 13: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12)) + Case 14: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13)) + Case 15: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14)) + Case 16: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15)) + Case 17: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16)) + Case 18: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17)) + Case 19: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18)) + Case 20: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19)) + Case 21: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)) + Case 22: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21)) + Case 23: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22)) + Case 24: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23)) + Case 25: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24)) + Case 26: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25)) + Case 27: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26)) + Case 28: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27)) + Case 29: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28)) + Case 30: Call CopyVariant(macCallByName, CallByName(obj, funcName, callerType, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)) + End Select +End Function diff --git a/CodeStore/index.xlsm_工作表1.bas b/CodeStore/index.xlsm_工作表1.bas new file mode 100644 index 0000000..6113d75 --- /dev/null +++ b/CodeStore/index.xlsm_工作表1.bas @@ -0,0 +1,56 @@ +Attribute VB_Name = "¤u§@ªí1" +Private Sub CommandButton21_Click() +' Application.Caption = PYEAR & Worksheets("°â»ù").Cells(3, 1) + Dim oSB As Object + Set oSB = CreateObject("System.Text.StringBuilder") + + oSB.AppendFormat_5 Nothing, "hello {0}", Array("simon") + Debug.Assert oSB.ToString = "hello simon" + +End Sub + +'Private Sub sample() +' Dim exl As Excel.Application +' Dim wb As Excel.Workbook +' Dim i As Integer +' Dim j As Integer +' Dim cnt As Integer +' Dim cn As New ADODB.Connection +' Dim t1 As Date +' Dim t2 As Date +' Dim t As Date +' +' t1 = Now +' +' Set exl = CreateObject("Excel.Application") +' Set wb = exl.Workbooks.Add +' +' exl.ActiveWorkbook.SaveAs (Excel.ThisWorkbook.Path & "\sample3.xls") +' exl.ActiveWorkbook.Close +' exl.Quit +' +' cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ +' "Data Source=" & Excel.ThisWorkbook.Path & "\sample3.xls;" & _ +' "Extended Properties=""Excel 8.0;HDR=YES;IMEX=0""" +' +' cn.Execute "CREATE TABLE [¤u§@ªí1$] (R INT, G INT, B INT)" +' cn.Execute "UPDATE [¤u§@ªí1$] SET R = 0" +' cn.Execute "UPDATE [¤u§@ªí1$] SET G = 1" +' cn.Execute "UPDATE [¤u§@ªí1$] SET B = 2" +' +' cnt = 3 +' For i = 1 To 10000 +' cn.Execute "INSERT INTO [¤u§@ªí1$] (R,G,B) VALUES (" & cnt & "," & cnt + 1 & "," & cnt + 2 & ")" +' cnt = cnt + 3 +' Next i +' +' cn.Close +' Set cn = Nothing +' t2 = Now +' +' t = t2 - t1 +' +' MsgBox Second(t) +'End Sub + + diff --git a/CodeStore/index.xlsm_工作表10.bas b/CodeStore/index.xlsm_工作表10.bas new file mode 100644 index 0000000..00614b8 --- /dev/null +++ b/CodeStore/index.xlsm_工作表10.bas @@ -0,0 +1,78 @@ +Attribute VB_Name = "¤u§@ªí10" +'**************** µ{¦¡ÅÜ¼Æ ****************** +Const PYEAR = 2023 +Const PCOMPANY = 27 +Const strXLSfile = "\index.xlsb" '¸ê®Æ¨Ó·½ +Const intFieldAmount = 20 'ªí¤¤Äæ¦ì¼Æ¥Ø +Const ITEMcount = 9 '³B²z«~¶µ¼Æ¥Ø +Const MSC = 5 '¨k¥Í¯Z¯Å¦æ¼Æ +Const MSD = 7 '¨k¥Í¤p­p¦æ¼Æ +Const WSC = 13 '¤k¥Í¯Z¯Å¦æ¼Æ +Const WSD = 15 '¤k¥Í¤p­p¦æ¼Æ +'******************************************** + +Private Sub Worksheet_Activate() +Dim p As Long +Dim diag As New ProgressDialogue +Application.Calculation = xlManual '³]¸m¤â°Ê­«ºâ +p = 0 +diag.Configure "§ó·s¸ê®Æ®É¶¡", "Now wasting your time...", 0, ITEMcount +diag.Show + For i = 1 To ITEMcount + Call subtotal(i, 1, 3) + Call subtotal(i, 2, 3) +diag.SetValue p +diag.SetStatus "Now wasting your time... " & p +p = p + 1 + Next i +diag.Hide +Application.Calculation = xlAutomatic '³]¸m¦Û°Ê­«ºâ + +End Sub + +Public Sub subtotal(strField As Variant, intRange As Variant, intRow As Variant) +' strField ¤p­p¨Ï¥ÎÄæ¦ì +' intRange ¨k¡B¤k 1,2 +' intRow ¶ñ¤J¦C¼Æ +Dim rstSubtotal As ADODB.Recordset +Dim strSQL As String +Dim intRowLoc As Integer +Dim fldClass, fldAmount As Field +Dim cellClass, cellData As Range + +Dim Cnmy As ADODB.Connection +Set Cnmy = Cnmyopen() +Set rstSubtotal = New ADODB.Recordset + strSQL = "SELECT departclass, sum(item" & strField & ") " & _ + "FROM clothing.BUYANDSELL " & _ + "where departclass<>'0' and " & Choose(intRange, "cus_sex=true and ", "cus_sex=false and ", "") & _ + "sid between " & PYEAR & PCOMPANY & "0000 AND " & PYEAR & PCOMPANY & "9999" & _ + " group by department;" +' Debug.Print strSQL +' rstSubtotal.CursorLocation = 3 'mysql RecordCount³s½uBUG by ÂŦâ¤pçE ¦Ñ¹xµ£ + rstSubtotal.Open strSQL, Cnmy + +Set fldClass = rstSubtotal.Fields(0) '¶µ¥Ø¤Ø¤o +Set fldAmount = rstSubtotal.Fields(1) '¶µ¥Ø¤Ø¤o¼Æ¶q + For intI = 1 To intFieldAmount '¦æ¶ñ¤J¦ì¸m +Set cellClass = Range(Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSC, WSC)), _ + Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSC, WSC))) 'Äæ¦ì¦WºÙ +Set cellData = Range(Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSD, WSD)), _ + Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSD, WSD))) 'Äæ¦ì¸ê®Æ + If Not rstSubtotal.EOF Then + cellClass.value = fldClass + cellData.value = fldAmount + rstSubtotal.MoveNext + Else + '²M°£¶µ¥Ø¤º®e + cellClass.ClearContents + cellData.ClearContents + End If + Next intI + + rstSubtotal.Close + Set rstSubtotal = Nothing + +End Sub + + diff --git a/CodeStore/index.xlsm_工作表11.bas b/CodeStore/index.xlsm_工作表11.bas new file mode 100644 index 0000000..eea8c4d --- /dev/null +++ b/CodeStore/index.xlsm_工作表11.bas @@ -0,0 +1,265 @@ +Attribute VB_Name = "¤u§@ªí11" +Private Const ROW_RESIZE_COUNT As Long = 1000 +Private Const OUTPUT_COL_START As Long = 3 +Private Const OUTPUT_COL_END As Long = 25 + +Private Enum OutputMode + OutputModePerson = 1 + OutputModeBS = 2 + OutputModeWS = 3 + OutputModeLS = 4 + OutputModeWP = 5 +End Enum + +' ¥Ø«e¼Ò²Õ¤º¥¼¨Ï¥Î¡A«O¯d¨Ñ¥¼¨ÓÂX¥R +Private Enum ValueMode + ValueModeCount = 1 + ValueModeSum = 2 +End Enum + +' ¿é¥X³]©wµ²ºc¡G¶°¤¤ºÞ²z¦U¼Ò¦¡¹ïÀ³ªºÄæ¦ì»P¯Á¤Þ +Private Type OutputConfig + ClearRows As Variant ' ­n²M°£¤º®eªº¦C¸¹°}¦C + ClassRowMale As Long ' ¨k¥Í¼ÐÅÒ¦C + DataRowMale As Long ' ¨k¥Í¸ê®Æ¦C + ClassRowFemale As Long ' ¤k¥Í¼ÐÅÒ¦C + DataRowFemale As Long ' ¤k¥Í¸ê®Æ¦C + GenderIndex As Long ' ¤À¸Ñ key «á¡A©Ê§O©Ò¦b¯Á¤Þ (0-based) + LabelIndex As Long ' ¤À¸Ñ key «á¡A¼ÐÅÒ©Ò¦b¯Á¤Þ (0-based) + SourceLabelCol As Long ' ¨Ó·½¤u§@ªí¤¤ªº¼ÐÅÒÄæ¦ì + SourceGenderCol As Long ' ¨Ó·½¤u§@ªí¤¤ªº©Ê§OÄæ¦ì +End Type + +Private Sub Worksheet_Activate() + Me.Cells(1, 1).value = "Update " & Date + + Dim startTime As Double + startTime = Timer + + Application.Calculation = xlManual + Call XLS_init + + Call CalcClassCounts(OutputModePerson) +' Call CalcClassCounts(OutputModeBS, 1) +' Call CalcClassCounts(OutputModeWS, 2) + ' Call CalcClassCounts(OutputModeLS, 3) + ' Call CalcClassCounts(OutputModeWP, 4) + + Application.Calculation = xlAutomatic + + Me.Cells(6, 1).value = "°õ¦æ®É¶¡¡G" & Format(Timer - startTime, "0.00") & " ¬í" +End Sub + +Public Sub CalcClassCounts(mode As Variant, Optional strField As Variant) + ' strField «O¯dµ¹¥¼¨Ó¤p­pÄæ¦ìÂX¥R¨Ï¥Î + Dim dictSubtotal As Object + Set dictSubtotal = ProcessCustomerData(mode, strField) + WriteOutputCommon dictSubtotal, mode +End Sub + +Private Sub WriteOutputCommon(ByVal dataDict As Object, ByVal mode As OutputMode) + Dim dataKey As Variant + Dim dataValue As Variant + Dim arrWords As Variant + Dim cfg As OutputConfig + Dim cellClass As Range + Dim cellData As Range + Dim classRow As Long + Dim dataRow As Long + Dim currentLabel As String + Dim colIndex As Long + Dim sortedKeys As Variant + Dim i As Long + + On Error GoTo WriteOutputError + + If dataDict Is Nothing Or dataDict.count = 0 Then Exit Sub + + cfg = GetOutputConfig(mode) + ClearOutputRows cfg.ClearRows + + colIndex = 2 ' ²Ä¤@­Ó¼ÐÅÒ·|Åܦ¨ 3¡A¹ïÀ³Äæ¦ì C + currentLabel = vbNullString + sortedKeys = SortKeys(dataDict.keys) + + For i = LBound(sortedKeys) To UBound(sortedKeys) + dataKey = sortedKeys(i) + arrWords = Split(dataKey, "_") + dataValue = dataDict(dataKey) + + If UBound(arrWords) < 1 Then + Debug.Print "ĵ§i: ¼Æ¾Ú®æ¦¡¿ù»~: " & dataKey + GoTo NextItem + End If + + ' ¼ÐÅÒ§ïÅܮɴ«¤U¤@Äæ + If CStr(arrWords(cfg.LabelIndex)) <> currentLabel Then + colIndex = colIndex + 1 + currentLabel = CStr(arrWords(cfg.LabelIndex)) + End If + + If arrWords(cfg.GenderIndex) = "¤k" Then + classRow = cfg.ClassRowFemale + dataRow = cfg.DataRowFemale + Else + classRow = cfg.ClassRowMale + dataRow = cfg.DataRowMale + End If + + Set cellClass = Me.Cells(classRow, colIndex) + Set cellData = Me.Cells(dataRow, colIndex) + cellClass.value = arrWords(cfg.LabelIndex) + cellData.value = dataValue + +NextItem: + Next i + + Exit Sub + +WriteOutputError: + MsgBox "¼g¤J¿é¥X®Éµo¥Í¿ù»~: " & Err.Description, vbExclamation, "¼g¤J¿ù»~" + Exit Sub +End Sub + +Private Sub ClearOutputRows(ByVal rows As Variant) + Dim idx As Long + + For idx = LBound(rows) To UBound(rows) + Me.Range(Me.Cells(rows(idx), OUTPUT_COL_START), Me.Cells(rows(idx), OUTPUT_COL_END)).ClearContents + Next idx +End Sub + +Private Function GetOutputConfig(ByVal mode As OutputMode) As OutputConfig + Dim cfg As OutputConfig + + Select Case mode + Case OutputModePerson + cfg.ClearRows = Array(2, 3, 4) + cfg.ClassRowMale = 2 + cfg.DataRowMale = 3 + cfg.ClassRowFemale = 2 + cfg.DataRowFemale = 4 + cfg.GenderIndex = 1 + cfg.LabelIndex = 0 + cfg.SourceLabelCol = 4 + cfg.SourceGenderCol = 7 + Case OutputModeBS + cfg.ClearRows = Array(9, 10, 11) + cfg.ClassRowMale = 9 + cfg.DataRowMale = 10 + cfg.ClassRowFemale = 9 + cfg.DataRowFemale = 11 + cfg.GenderIndex = 1 + cfg.LabelIndex = 0 + cfg.SourceLabelCol = 12 + cfg.SourceGenderCol = 5 + Case OutputModeWS + cfg.ClearRows = Array(16, 17, 18) + cfg.ClassRowMale = 16 + cfg.DataRowMale = 17 + cfg.ClassRowFemale = 16 + cfg.DataRowFemale = 18 + cfg.GenderIndex = 1 + cfg.LabelIndex = 0 + cfg.SourceLabelCol = 13 + cfg.SourceGenderCol = 5 + Case OutputModeLS + cfg.ClearRows = Array(33, 36, 38, 41) + cfg.ClassRowMale = 33 + cfg.DataRowMale = 36 + cfg.ClassRowFemale = 38 + cfg.DataRowFemale = 41 + cfg.GenderIndex = 0 + cfg.LabelIndex = 1 + cfg.SourceLabelCol = 0 ' TODO: ½Ð¶ñ¤J¹ê»ÚÄæ¦ì + cfg.SourceGenderCol = 0 ' TODO: ½Ð¶ñ¤J¹ê»ÚÄæ¦ì + Case OutputModeWP + cfg.ClearRows = Array(45, 48, 50, 53) + cfg.ClassRowMale = 45 + cfg.DataRowMale = 48 + cfg.ClassRowFemale = 50 + cfg.DataRowFemale = 53 + cfg.GenderIndex = 0 + cfg.LabelIndex = 1 + cfg.SourceLabelCol = 0 ' TODO: ½Ð¶ñ¤J¹ê»ÚÄæ¦ì + cfg.SourceGenderCol = 0 ' TODO: ½Ð¶ñ¤J¹ê»ÚÄæ¦ì + Case Else + Err.Raise vbObjectError + 1, "GetOutputConfig", "¥¼ª¾ªº¿é¥X¼Ò¦¡" + End Select + + GetOutputConfig = cfg +End Function + +Private Function ProcessCustomerData(mode As Variant, Optional strField As Variant) As Object + Dim dict As Object + Dim sourceRange As Variant + Dim wsSource As Worksheet + Dim i As Long + Dim cfg As OutputConfig + Dim labelValue As Variant + Dim genderValue As Variant + Dim dictKey As String + + Set dict = CreateObject("Scripting.Dictionary") + Set wsSource = ActiveWorkbook.Worksheets("±b°È") + sourceRange = wsSource.Range("Cu±b°È").Resize(ROW_RESIZE_COUNT) + cfg = GetOutputConfig(mode) + + For i = 1 To UBound(sourceRange, 1) + If Not IsEmpty(sourceRange(i, 1)) Then + labelValue = sourceRange(i, cfg.SourceLabelCol) + genderValue = sourceRange(i, cfg.SourceGenderCol) + + If cfg.LabelIndex = 0 Then + dictKey = labelValue & "_" & genderValue + Else + dictKey = genderValue & "_" & labelValue + End If + + SetDictionaryValue dict, dictKey, 1 + End If + Next i + + Set ProcessCustomerData = dict +End Function + +Private Sub SetDictionaryValue(ByRef dict As Object, ByVal key As Variant, ByVal value As Variant) + If dict.Exists(key) Then + dict(key) = dict(key) + value + Else + dict.Add key, value + End If +End Sub + +' ¥H®ðªw±Æ§Çªk¦^¶Ç±Æ§Ç«áªº key °}¦C¡AÁקK¨Ì¿à¥~³¡ stdArray ¨ç¦¡®w +Private Function SortKeys(keys As Variant) As Variant + Dim arr() As Variant + Dim i As Long + Dim j As Long + Dim temp As Variant + Dim n As Long + + n = UBound(keys) - LBound(keys) + 1 + If n <= 1 Then + SortKeys = keys + Exit Function + End If + + ReDim arr(LBound(keys) To UBound(keys)) + For i = LBound(keys) To UBound(keys) + arr(i) = keys(i) + Next i + + For i = LBound(arr) To UBound(arr) - 1 + For j = i + 1 To UBound(arr) + If arr(i) > arr(j) Then + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + End If + Next j + Next i + + SortKeys = arr +End Function + diff --git a/CodeStore/index.xlsm_工作表14.bas b/CodeStore/index.xlsm_工作表14.bas new file mode 100644 index 0000000..843b78a --- /dev/null +++ b/CodeStore/index.xlsm_工作表14.bas @@ -0,0 +1,71 @@ +Attribute VB_Name = "¤u§@ªí14" +Private Sub Worksheet_Activate() + Dim startTime As Double, totalRows As Long + Dim dict As Object + Dim itemAddup As New stdArray + Dim changeRange As Variant + Dim tmp As stdArray + Dim oArr As Variant, pArr As Variant, qArr As Variant + Dim i As Long, arrWords As Variant + Dim key As Variant, vIter As Variant + + ' ³Ð«Ø¦r¨å + Set dict = CreateObject("Scripting.Dictionary") + + ' ³]¸m½d³ò + changeRange = Me.Range("ChangeTBL").Resize(100) + + ' ¶}©l­p®É + startTime = Timer + + ' ¶ñ¥R¦r¨å + For i = 1 To UBound(changeRange) + If Not IsEmpty(changeRange(i, 1)) Then + Call FillDictionary(dict, changeRange(i, 1) & "_" & changeRange(i, 2), changeRange(i, 3)) + End If + Next i + + ' ±N¦r¨å¤¤ªº¶µ¥Ø²K¥[¨ì itemAddup + Set itemAddup = stdArray.Create + For Each key In dict.keys + itemAddup.Push key & "_" & dict(key) + Next key + totalRows = dict.count + + ' ªì©l¤Æ¿é¥X½d³òªº¼Æ²Õ + Me.Range("O3").CurrentRegion.ClearContents + oArr = Me.Range("O3").Resize(totalRows) + pArr = Me.Range("P3").Resize(totalRows) + qArr = Me.Range("Q3").Resize(totalRows) + + ' ±Æ§Ç¨Ã±N­È¶ñ¥R¨ìÁ{®É¼Æ²Õ + Set tmp = stdArray.Create + itemAddup.Sort().ForEach stdLambda.Create("$1.push($2)").Bind(tmp) + + ' ­¡¥NÁ{®É¼Æ²Õ¨Ã±N­È¶ñ¥R¨ì¬ÛÀ³ªºÄæ¦ì + i = 1 + For Each vIter In tmp + arrWords = Split(vIter, "_") + oArr(i, 1) = arrWords(0) + pArr(i, 1) = arrWords(1) + qArr(i, 1) = arrWords(2) + i = i + 1 + Next vIter + + ' Åã¥Ü°õ¦æ®É¶¡ + Me.Range("O1").value = Timer - startTime + + ' ±Nµ²ªG¼g¦^¤u§@ªí + Me.Range("O3").Resize(totalRows).value = oArr + Me.Range("P3").Resize(totalRows).value = pArr + Me.Range("Q3").Resize(totalRows).value = qArr +End Sub + +Private Sub FillDictionary(ByRef dict As Object, item As Variant, itemValue As Variant) + If dict.Exists(item) Then + dict(item) = dict(item) + itemValue + Else + dict.Add item, itemValue + End If +End Sub + diff --git a/CodeStore/index.xlsm_工作表15.bas b/CodeStore/index.xlsm_工作表15.bas new file mode 100644 index 0000000..451f2e2 --- /dev/null +++ b/CodeStore/index.xlsm_工作表15.bas @@ -0,0 +1,2 @@ +Attribute VB_Name = "¤u§@ªí15" + diff --git a/CodeStore/index.xlsm_工作表2.bas b/CodeStore/index.xlsm_工作表2.bas new file mode 100644 index 0000000..bdf91b7 --- /dev/null +++ b/CodeStore/index.xlsm_工作表2.bas @@ -0,0 +1,2 @@ +Attribute VB_Name = "¤u§@ªí2" + diff --git a/CodeStore/index.xlsm_工作表3.bas b/CodeStore/index.xlsm_工作表3.bas new file mode 100644 index 0000000..4bd7855 --- /dev/null +++ b/CodeStore/index.xlsm_工作表3.bas @@ -0,0 +1,2 @@ +Attribute VB_Name = "¤u§@ªí3" + diff --git a/CodeStore/index.xlsm_工作表4.bas b/CodeStore/index.xlsm_工作表4.bas new file mode 100644 index 0000000..3f3ac5b --- /dev/null +++ b/CodeStore/index.xlsm_工作表4.bas @@ -0,0 +1,99 @@ +Attribute VB_Name = "¤u§@ªí4" +'**************** µ{¦¡ÅÜ¼Æ ********************** +Const PYEAR = 2024 '¦~«× +Const PCOMPANY = 27 +Const strXLSfile = "\index.xlsb" '¸ê®Æ¨Ó·½ +'************************************************ + +Private Sub CommandButton21_Click() +Dim strSQL As String +On Error GoTo Err_cmdYes_Click + +' ¶×¤J¸ê®Æ + Call updSELLUP + +Exit_cmdYes_Click: + Exit Sub + +Err_cmdYes_Click: + MsgBox Err.Description + Resume Exit_cmdYes_Click + +End Sub + +' ¶×¤J¶q¨­¸ê®Æ +Public Sub updSELLUP() +'====================================+ +Dim p As Long '| +Dim diag As New ProgressDialogue '| +'====================================+ +Dim sb As StringBuilder +Set sb = New StringBuilder +Dim rstItem As New ADODB.Recordset +Dim rstTBL As New ADODB.Recordset 'excel¸ê®Æªí +Dim strSQL, strSQLitem As String +Dim fld As ADODB.Field +Dim Cnxn, Cnmy As ADODB.Connection +Set Cnmy = Cnmyopen() +Set Cnxn = Cnxnopen(XLSfile, "1") + + sb.Append "Select " & PYEAR & PCOMPANY & " & Format([½s¸¹],'0000') AS ID,[¯ZID] as depart,[©Ê§O] as sex" & _ + ", [®Õµu¤Ø½X] as itsz1, [®Õµu­qÁÊ] as item1, [®Õªø¤Ø½X] as itsz2, [®Õªø­qÁÊ] as item2, [®Õ®L¤Ø½X] as itsz3, [®Õ®L­qÁÊ] as item3" & _ + ", [®Õ¥V¤Ø½X] as itsz4, [®Õ¥V­qÁÊ] as item4, [®Õ¸È¤Ø½X] as itsz5, [®Õ¸È­qÁÊ] as item5" & _ + ", [­I¤ß¤Ø½X] as itsz6, [­I¤ß­qÁÊ] as item6, 0 as itsz7, [®Ñ¥]­qÁÊ] as item7, 0 as itsz8, [»â±a­qÁÊ] as item8, 0 as itsz9, [¸y±a­qÁÊ] as item9" & _ + " FROM [±b°È$];" +' Debug.Print sb.toString +With rstTBL + .Open sb.ToString, Cnxn, adOpenStatic, adLockOptimistic, adCmdText + lastdepart = !depart +'====================================================================================+ +p = 0 '| +diag.Configure "§ó·s¸ê®Æ®É¶¡", "Now wasting your time...", 0, .RecordCount '| +diag.Show '| +'====================================================================================+ + strSQLitem = "SELECT pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure FROM GoodsUse" & _ + " WHERE corp_use=" & PCOMPANY & " and Depart_Use=" & !depart & _ + " order by pno;" + rstItem.Open strSQLitem, Cnmy + While Not (.EOF Or diag.cancelIsPressed) + If Not lastdepart = !depart Then + rstItem.Close + strSQLitem = "SELECT pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure FROM GoodsUse" & _ + " WHERE corp_use=" & PCOMPANY & " and Depart_Use=" & !depart & _ + " order by pno;" + rstItem.Open strSQLitem, Cnmy +' Range("AF3").CopyFromRecordset rstItem + End If + i = 1 + rstItem.MoveFirst + sb.Clear + sb.Append "UPDATE SELLUP SET " + '¸ê®Æ¨Ó·½°ÊºA³]©w + While Not rstItem.EOF + sb.Append "itsz" & i & "=goodsid('" & .Fields.item("itsz" & i) & "'," & IIf(!sex = "¨k", rstItem!mtmodel, rstItem!wtmodel) & ")," & _ + "item" & i & "=" & .Fields.item("item" & i) + i = i + 1 + rstItem.MoveNext + If Not rstItem.EOF Then sb.Append "," + Wend + sb.Append " WHERE id=" & !ID & ";" +Debug.Print sb.ToString + ' Cnmy.Execute sb.toString + lastdepart = !depart + .MoveNext +'================================================+ +diag.SetValue p '| +diag.SetStatus "Now wasting your time... " & p '| +p = p + 1 '| +'================================================+ + Wend +'============+ +diag.Hide '| +'============+ + .Close +End With + Cnxn.Close + +End Sub + + diff --git a/CodeStore/index.xlsm_工作表5.bas b/CodeStore/index.xlsm_工作表5.bas new file mode 100644 index 0000000..fce3b9f --- /dev/null +++ b/CodeStore/index.xlsm_工作表5.bas @@ -0,0 +1,2 @@ +Attribute VB_Name = "¤u§@ªí5" + diff --git a/CodeStore/index.xlsm_工作表6.bas b/CodeStore/index.xlsm_工作表6.bas new file mode 100644 index 0000000..949ee69 --- /dev/null +++ b/CodeStore/index.xlsm_工作表6.bas @@ -0,0 +1,2 @@ +Attribute VB_Name = "¤u§@ªí6" + diff --git a/CodeStore/index.xlsm_工作表7.bas b/CodeStore/index.xlsm_工作表7.bas new file mode 100644 index 0000000..d648801 --- /dev/null +++ b/CodeStore/index.xlsm_工作表7.bas @@ -0,0 +1,83 @@ +Attribute VB_Name = "¤u§@ªí7" +'**************** µ{¦¡ÅÜ¼Æ ****************** +Const strXLSfile = "\index.xlsm" '¸ê®Æ¨Ó·½ +Const idxStart = 1810 +Const idxEnd = 1849 +Const idxRange = "argRange" +'******************************************** + +Private Sub CommandButton1_Click() +Dim sb As StringBuilder +Set sb = New StringBuilder + +Dim strSQL As String +On Error GoTo Err_cmdYes_Click +Dim Cnmy As ADODB.Connection +Set Cnmy = Cnmyopen() + +'²M°£Â¸ê®Æ + sb.Append "delete FROM DEPARTMENT where id BETWEEN " & idxStart & " AND " & idxEnd & ";" + Cnmy.Execute sb.ToString '§R°£¯¸ÂI +' §ó·s¸ê®Æ + Call renewDepart(Cnmy) + +Exit_cmdYes_Click: + Exit Sub + +Err_cmdYes_Click: + MsgBox Err.Description + Resume Exit_cmdYes_Click + +End Sub + +Public Sub renewDepart(Cnmy As ADODB.Connection) +'************************************* +Dim p As Long '* +Dim diag As New ProgressDialogue '* +'************************************* +' §ó·s¯¸ÂI¸ê®Æ +Dim sb As StringBuilder +Set sb = New StringBuilder + +Dim Cnxn As ADODB.Connection +Dim rstTBL As New ADODB.Recordset +Dim strSQL As String + +Set Cnxn = Cnxnopen(strXLSfile, "1") + + sb.Append "Select ¥N½X as id, ¬ì§O as title, ¥N½X as depart FROM [¤Þ¼Æ$" & _ + Replace(Sheets("¤Þ¼Æ").Range(idxRange).Address, "$", "") & "];" +' Debug.Print sb.toString + rstTBL.Open sb.ToString, Cnxn, adOpenStatic, adLockOptimistic, adCmdText +'************************************************************************************* +p = 0 '* +diag.Configure "Wasting Time", "Now wasting your time...", 0, rstTBL.RecordCount '* +diag.Show '* +'************************************************************************************* + sb.Clear + sb.Append "INSERT INTO DEPARTMENT(id,title,depart) VALUES " + + While Not (rstTBL.EOF Or diag.cancelIsPressed) + If Not IsNull(rstTBL.Fields.item("title")) Then + sb.Append "(" & rstTBL.Fields.item("id") & ",'" + sb.Append rstTBL.Fields.item("title") & "','" + sb.Append rstTBL.Fields.item("depart") & "')" + End If + rstTBL.MoveNext + If Not rstTBL.EOF Then + sb.Append "," + End If +'************************************************* +diag.SetValue p '* +diag.SetStatus "Now wasting your time... " & p '* +p = p + 1 '* +'************************************************* + Wend +' Debug.Print sb.toString + Cnmy.Execute sb.ToString + rstTBL.Close +'************* +diag.Hide '* +'************* +End Sub + diff --git a/CodeStore/index.xlsm_工作表8.bas b/CodeStore/index.xlsm_工作表8.bas new file mode 100644 index 0000000..f8eec9b --- /dev/null +++ b/CodeStore/index.xlsm_工作表8.bas @@ -0,0 +1,207 @@ +Attribute VB_Name = "¤u§@ªí8" +'**************** µ{¦¡ÅÜ¼Æ ****************** +Const PYEAR = 2024 +Const PCOMPANY = 27 +Const strXLSfile = "\index.xlsb" '¸ê®Æ¨Ó·½ +Const FieldAmount = 23 'ªí¤¤Äæ¦ì¼Æ¥Ø +Const srtRange = "wordSort" '±Æ§Ç¦WºÙ +Const ITEMcount = 9 '³B²z«~¶µ¼Æ¥Ø +Dim SELLITEM() + +Private Sub Worksheet_Activate() +'******************************************** +' === ¨Ï¥Î«~¶µ¡AÄæ¦ì¡A¦æ¼Æ === +SELLITEM() = Array(Array("", 0, True) _ + , Array("®Õµu", 9, True) _ + , Array("®Õªø", 21, True) _ + , Array("®Õ®L", 33, True) _ + , Array("®Õ¥V", 45, True) _ + , Array("®Õ¸È", 57, True) _ + , Array("­I¤ß", 69, True) _ + , Array("»â±a", 81, False) _ + , Array("¸y±a", 89, False) _ + , Array("®Ñ¥]", 97, False)) +'******************************************** +'====================================+ +Dim p As Long '| +Dim diag As New ProgressDialogue '| +'====================================+ + Call XLS_init + Application.Calculation = xlManual '³]¸m¤â°Ê­«ºâ + + Cells(1, 1).value = "²Î­p" & Date + Call statClass(2, 3) '¤H¼Æ²Î­p +'====================================================================================+ +p = 0 '| +diag.Configure "§ó·s¸ê®Æ®É¶¡", "Now wasting your time...", 0, ITEMcount '| +diag.Show '| +'====================================================================================+ + For i = 1 To ITEMcount + Call QueryItem(SELLITEM(i)(0), SELLITEM(i)(1), SELLITEM(i)(2)) +'================================================+ +diag.SetValue p '| +diag.SetStatus "Now wasting your time... " & p '| +p = p + 1 '| +'================================================+ + Next i +'============+ +diag.Hide '| +'============+ + Application.Calculation = xlAutomatic '³]¸m¦Û°Ê­«ºâ +End Sub + +Public Sub QueryItem(strItem As Variant, intRow As Variant, blnNosize As Variant) +' strItem ¶µ¥Ø +' intRow ¶ñªí¦æ¦ì¸m +Dim rstEmployees As New ADODB.Recordset +Dim strSQLEmployees As String +Dim Cnxn As ADODB.Connection +Set Cnxn = Cnxnopen(XLSfile, "1") +If blnNosize = True Then + strSQLEmployees = "SELECT [" & strItem & "¤Ø½X],sum([" & strItem & "­qÁÊ]) as people" & _ + " FROM [±b°È$]A LEFT JOIN [¤Þ¼Æ$" & Replace(Sheets("¤Þ¼Æ").Range(srtRange).Address, "$", "") & _ + "]B ON A.[" & strItem & "¤Ø½X]=B.[±Æ§Ç]" & _ + " where [©Ê§O]='¨k'" & _ + " group by [" & strItem & "¤Ø½X],B.[§Ç¸¹]" & _ + " ORDER BY B.[§Ç¸¹];" +' Debug.Print strSQLEmployees +rstEmployees.Open strSQLEmployees, Cnxn, adOpenStatic, adLockOptimistic, adCmdText + Call QueryItemEx1(rstEmployees, "¨k" & strItem, intRow) +rstEmployees.Close + strSQLEmployees = "SELECT [" & strItem & "¤Ø½X],sum([" & strItem & "­qÁÊ]) as people" & _ + " FROM [±b°È$]A LEFT JOIN [¤Þ¼Æ$" & Replace(Sheets("¤Þ¼Æ").Range(srtRange).Address, "$", "") & _ + "]B ON A.[" & strItem & "¤Ø½X]=B.[±Æ§Ç]" & _ + " where [©Ê§O]='¤k'" & _ + " group by [" & strItem & "¤Ø½X],B.[§Ç¸¹]" & _ + " ORDER BY B.[§Ç¸¹];" +' Debug.Print strSQLEmployees +rstEmployees.Open strSQLEmployees, Cnxn, adOpenStatic, adLockOptimistic, adCmdText + Call QueryItemEx1(rstEmployees, "¤k" & strItem, intRow + 5) +Else + strSQLEmployees = "SELECT [¯Z¯Å],sum(iif([©Ê§O]='¨k',[" & strItem & "­qÁÊ],0)) as boys,sum(iif([©Ê§O]='¤k',[" & strItem & "­qÁÊ],0)) as girls" & _ + " FROM [±b°È$]" & _ + " group by [¯Z¯Å]" & _ + " ORDER BY [¯Z¯Å];" +' Debug.Print strSQLEmployees +rstEmployees.Open strSQLEmployees, Cnxn, adOpenStatic, adLockOptimistic, adCmdText + Call QueryItemEx2(rstEmployees, strItem, intRow) +End If +rstEmployees.Close +Set rstEmployees = Nothing +Cnxn.Close + +End Sub + +Public Sub QueryItemEx1(rstEmployees As ADODB.Recordset, strItem As Variant, intRow As Variant) +' rstEmployees ²Î­p¸ê®Æ +' strItem ¶µ¥Ø +' intRow ¶ñªí¦æ¦ì¸m +Dim intRowLoc As Integer +Dim fldSize, fldPeoples As Field +Dim cellsName, cellsData1 As Range + '¶ñ¤J¶µ¥Øªº¦C¼Æ + For intJ = 1 To WorksheetFunction.RoundUp(rstEmployees.RecordCount / FieldAmount, 0) '¦æ¼Æ¥Ø­­¨î + If Not intJ = 1 Then 'intJªí¤@½d³ò + intRowLoc = intRow + (12 * (intJ - 1)) + Else + intRowLoc = intRow + End If + Cells(intRowLoc, 1).value = strItem '¶µ¥Ø¦WºÙ +Set fldSize = rstEmployees.Fields(0) +Set fldPeoples = rstEmployees.Fields(1) + For intI = 1 To FieldAmount '¦æ¶ñ¤J¦ì¸m +Set cellsName = Range(Cells(intRowLoc, 2 + intI), Cells(intRowLoc, 2 + intI)) 'Äæ¦ì¦WºÙ +Set cellsData1 = Range(Cells(intRowLoc + 3, 2 + intI), Cells(intRowLoc + 3, 2 + intI)) 'Äæ¦ì¸ê®Æ + If Not rstEmployees.EOF Then + cellsName.value = IIf(fldSize = "0", "¥¼©w", fldSize) + cellsData1.value = fldPeoples + rstEmployees.MoveNext + Else + '²M°£¶µ¥Ø¤º®e + cellsName.ClearContents + cellsData1.ClearContents + End If + Next intI + Next intJ + +End Sub + +Public Sub QueryItemEx2(rstEmployees As ADODB.Recordset, strItem As Variant, intRow As Variant) +' rstEmployees ²Î­p¸ê®Æ +' strItem ¶µ¥Ø +' intRow ¶ñªí¦æ¦ì¸m +Dim intRowLoc As Integer +Dim fldClass, fldBoys, fldGirls As Field +Dim cellsName, cellsData1 As Range + '¶ñ¤J¶µ¥Øªº¦C¼Æ + For intJ = 1 To WorksheetFunction.RoundUp(rstEmployees.RecordCount / FieldAmount, 0) '¦æ¼Æ¥Ø­­¨î + If Not intJ = 1 Then 'intJªí¤@½d³ò + intRowLoc = intRow + (12 * (intJ - 1)) + Else + intRowLoc = intRow + End If + Cells(intRowLoc, 1).value = strItem '¶µ¥Ø¦WºÙ +Set fldClass = rstEmployees.Fields(0) +Set fldBoys = rstEmployees.Fields(1) +Set fldGirls = rstEmployees.Fields(2) + For intI = 1 To FieldAmount '¦æ¶ñ¤J¦ì¸m +Set cellsName = Range(Cells(intRowLoc, 2 + intI), Cells(intRowLoc, 2 + intI)) 'Äæ¦ì¦WºÙ +Set cellsData1 = Range(Cells(intRowLoc + 3, 2 + intI), Cells(intRowLoc + 3, 2 + intI)) 'Äæ¦ì¸ê®Æ +Set cellsData2 = Range(Cells(intRowLoc + 4, 2 + intI), Cells(intRowLoc + 4, 2 + intI)) 'Äæ¦ì¸ê®Æ + If Not rstEmployees.EOF Then + cellsName.value = IIf(fldClass = "0", "¥¼©w", fldClass) + cellsData1.value = fldBoys + cellsData2.value = fldGirls + rstEmployees.MoveNext + Else + '²M°£¶µ¥Ø¤º®e + cellsName.ClearContents + cellsData1.ClearContents + cellsData2.ClearContents + End If + Next intI + Next intJ + +End Sub + +Public Sub statClass(intRow As Variant, intDataRow As Variant) +' intRow ¶ñªí¦æ¦ì¸m +' intDataRow ¶ñ¸ê®Æ¦æ¦C¼Æ +Dim rstClass As New ADODB.Recordset +Dim strSQLclass As String +Dim intRowLoc As Integer +Dim fldClass, fldBoys, fldGirls As Field +Dim cellsName, cellsData1, cellsData2 As Range +Dim Cnxn As ADODB.Connection +Set Cnxn = Cnxnopen(XLSfile, "1") + + strSQLclass = "SELECT [¯Z¯Å],sum(iif([©Ê§O]='¨k',1,0)) as boys,sum(iif([©Ê§O]='¤k',1,0)) as girls" & _ + " FROM [±b°È$]" & _ + " group by [¯Z¯Å];" +' Debug.Print strSQLclass + rstClass.Open strSQLclass, Cnxn, adOpenStatic, adLockOptimistic, adCmdText +Set fldClass = rstClass.Fields(0) +Set fldBoys = rstClass.Fields(1) +Set fldGirls = rstClass.Fields(2) + For intI = 1 To FieldAmount '¦æ¶ñ¤J¦ì¸m +Set cellsName = Range(Cells(intRow, 2 + intI), Cells(intRow, 2 + intI)) 'Äæ¦ì¦WºÙ +Set cellsData1 = Range(Cells(intDataRow, 2 + intI), Cells(intDataRow, 2 + intI)) 'Äæ¦ì¸ê®Æ +Set cellsData2 = Range(Cells(intDataRow + 1, 2 + intI), Cells(intDataRow + 1, 2 + intI)) 'Äæ¦ì¸ê®Æ + If Not rstClass.EOF Then + cellsName.value = fldClass + cellsData1.value = fldBoys + cellsData2.value = fldGirls + rstClass.MoveNext + Else + '²M°£¶µ¥Ø¤º®e + cellsName.ClearContents + cellsData1.ClearContents + cellsData2.ClearContents + End If + Next intI + rstClass.Close + Cnxn.Close + +End Sub + + diff --git a/CodeStore/index.xlsm_工作表9.bas b/CodeStore/index.xlsm_工作表9.bas new file mode 100644 index 0000000..94a95ed --- /dev/null +++ b/CodeStore/index.xlsm_工作表9.bas @@ -0,0 +1,77 @@ +Attribute VB_Name = "¤u§@ªí9" +'**************** µ{¦¡ÅÜ¼Æ ****************** +'Const PYEAR = 2020 '¦~«× +'Const PCOMPANY = 11 '¤½¥q¥N½X +'Const strXLSfile = "\¨îªA.xlsm" '¸ê®Æ¨Ó·½ +'Const strLookup = "¤¤ªo¹Å¸q" '¨Ï¥Îµ{¦¡ªº¾Ç®Õ +Const ITEMcount = 5 '¶×¤J³B²z«~¶µ¼Æ¥Ø +Const intFieldAmount = 22 'ªí¤¤Äæ¦ì¼Æ¥Ø +Const xlsRANGE = "[¤Þ¼Æ$J1:K23]" '±Æ§Ç¤Þ¼Æªí¤¤¦ì¸m +Const intFLeft = 23 '¶ñ¤Jªí®æ¥ªÃä¬É + +Private Sub CommandButton1_Click() +Dim strSQL As String +On Error GoTo Err_cmdYes_Click + +Application.Calculation = xlManual '³]¸m¤â°Ê­«ºâ +'¬d¸ßÄæ¦ì¦WºÙtable +Dim Cnxn As New ADODB.Connection +Set Cnxn = Cnxnopen(XLSfile, "1") + + Range("W2:AF28").Clear '²M°£¨Ï¥Î½d³òÀx¦s®æ + Call FfName(Cnxn, "®Õ¸È", 2) +' Call FfName(Cnxn, "µu³S", 9) +' Call FfName(Cnxn, "ªø¿Ç", 16) +' Call FfName(Cnxn, "§¨§J", 23) +' +Application.Calculation = xlAutomatic ' ³]¸m¦Û°Ê­«ºâ +Cnxn.Close +Set Cnxn = Nothing + +Exit_cmdYes_Click: + Exit Sub + +Err_cmdYes_Click: + MsgBox Err.Description + Resume Exit_cmdYes_Click + +End Sub + +Private Sub FfName(Cnxn As ADODB.Connection, strItem As String, intRow As Integer) +' intRange ¨k¡B¤k¡B¥þ 1,2,3 +' intRow ¶ñªí¦æ¦ì¸m +Dim rstFfname As New ADODB.Recordset +Dim strSQL As String +Dim intRowLoc As Integer + 'select ¤Ø½X,¨k¤H¼Æ,¨k¼Æ¶q,¤k¤H¼Æ,¤k¼Æ¶q,¦X­p + strSQL = "Select " & strItem & "¤Ø½X,sum(IIf(©Ê§O='¨k',1,0))," & "sum(IIf(©Ê§O='¨k'," & strItem & "­qÁÊ,0))," & _ + "sum(IIf(©Ê§O='¨k',0,1)),sum(IIf(©Ê§O='¨k',0," & strItem & "­qÁÊ))," & "sum(" & strItem & "­qÁÊ)," & xlsRANGE & ".id " & _ + "FROM [²§°Ê$] INNER JOIN " & xlsRANGE & " ON " & xlsRANGE & ".strorder = [²§°Ê$]." & strItem & "¤Ø½X" & _ + " WHERE isnull([²§°Ê$].­û½s)" & _ + " GROUP BY " & xlsRANGE & ".id,[²§°Ê$]." & strItem & "¤Ø½X" & _ + " ORDER BY " & xlsRANGE & ".id;" +' Debug.Print strSQL + rstFfname.Open strSQL, Cnxn, adOpenStatic, adLockOptimistic, adCmdText + '¶ñ¤J¶µ¥Ø + For intJ = 1 To WorksheetFunction.RoundUp(rstFfname.RecordCount / intFieldAmount, 0) '¦æ¼Æ¥Ø­­¨î + intRowLoc = IIf(intJ <> 1, intRow + (2 * (intJ - 1)), intRow) 'intJªí¤@½d³ò + For intI = 1 To intFieldAmount + If Not rstFfname.EOF Then + For intK = 0 To 5 '¦æ¶ñ¤J¦ì¸m + Cells(intRowLoc + intK, intFLeft + intI).Borders.LineStyle = xlContinuous + Cells(intRowLoc + intK, intFLeft + intI).value = rstFfname.Fields(intK) + Next intK + rstFfname.MoveNext + End If + Next intI + Next intJ +rstFfname.Close +Set rstFfname = Nothing + +End Sub + + + + + +