Add files via upload

src/CallByFunc.cls

@@ -0,0 +1,87 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CallByFunc"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+'CallByNameを行うための情報を格納するクラス
+
+Implements IFunc
+Option Explicit
+
+'スコープ適当。Argumentsをどんな形で見せるか…
+Private clsMemberName As String
+Private clsCallType As VBA.VbCallType
+Private clsArguments() As Variant
+Private clsChildCallBack As IFunc
+
+Property Get MemberName() As String:        Let MemberName = clsMemberName:         End Property
+Property Get CallType() As VBA.VbCallType:  Let CallType = clsCallType:             End Property
+Function Arguments() As Variant:       Let Arguments = clsArguments:           End Function
+Property Get ChildCallBack() As IFunc:  Set ChildCallBack = clsChildCallBack:   End Property
+Property Set ChildCallBack(ByVal iCB As IFunc): Set clsChildCallBack = iCB:     End Property
+
+'コンストラクタ・既定のプロシージャ
+    '既定のインスタンスを使って
+        'CallByFunc( ～
+    'と使用することを想定
+
+
+Public Function Init( _
+             ByVal iMemeberName As String, _
+             ByVal iCallType As VBA.VbCallType, _
+        ParamArray iArgs() As Variant _
+    ) As CallByFunc
+Attribute Init.VB_UserMemId = 0
+'
+
+'Attribute Init.VB_UserMemId = 0
+    If Me Is CallByFunc Then
+        Dim callArgs() As Variant
+        ReDim callArgs(LBound(iArgs) To UBound(iArgs) + 2)
+        callArgs(0) = iMemeberName: callArgs(1) = iCallType
+        Dim i As Long
+        For i = 2 To UBound(callArgs)
+            callArgs(i) = iArgs(i - 2)
+        Next i
+
+        Dim tCallByFunc As CallByFunc
+        Set tCallByFunc = New CallByFunc
+        Set Init = CallByNameEx(tCallByFunc, "Init", VbMethod, callArgs)
+        Exit Function
+    Else
+
+        Static alreadyInit As Boolean
+        If alreadyInit Then Err.Raise 17
+
+        Let clsMemberName = iMemeberName
+        Let clsCallType = iCallType
+        Let clsArguments = iArgs
+
+        Let alreadyInit = True
+
+        Set Init = Me
+    End If
+End Function
+
+Function SetChild(ByVal callBack As IFunc) As CallByFunc
+    Set clsChildCallBack = callBack
+    Set SetChild = Me
+End Function
+
+Private Function IFunc_Exec(iElement As Variant) As Variant
+    Dim tmp As Variant
+    AssignVal tmp, CallByNameEx(iElement, clsMemberName, clsCallType, clsArguments)
+
+    If clsChildCallBack Is Nothing Then
+        AssignVal IFunc_Exec, tmp
+    Else
+        AssignVal IFunc_Exec, clsChildCallBack.Exec(tmp)
+    End If
+End Function
+
+
+

src/CompareOperator.cls

@@ -0,0 +1,131 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CompareOperator"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+'演算子による比較用クラス
+    '大分汚いのできれいにしたいけれど…
+
+Implements IFunc
+Option Explicit
+
+
+'比較演算子指定用
+    '名前はPowerShellの比較演算子をイメージ
+Public Enum CompareOperators
+    opEq        '=
+    opNe        '<>
+    opLt        '<
+    opLe        '<=
+    opGt        '>
+    opGe        '>=
+    opLike      ' Like
+    opNotLike   '( Like ) = False
+    opiMatch    'RegExp.Test( ) = True  / IgnoreCase = True
+    opiNotMatch 'RegExp.Test( ) = False / IgnoreCase = True
+    opcMatch    'RegExp.Test( ) = True  / IgnoreCase = False
+    opcNotMatch 'RegExp.Test( ) = False / IgnoreCase = False
+    opIs        ' Is = True
+    opIsNot     ' Is = False
+End Enum
+
+'スコープ適当。読み取り専用プロパティにする予定
+Public Operator As CompareOperators
+Public Expression As Variant
+
+Private clsRegExp As VBScript_RegExp_55.RegExp
+
+
+Public Function Init( _
+        ByVal iOperator As CompareOperators, _
+        ByVal iExpresion As Variant _
+    ) As CompareOperator
+Attribute Init.VB_UserMemId = 0
+'Attribute Init.VB_UserMemId = 0
+
+
+    If Me Is CompareOperator Then
+        With New CompareOperator
+            Set Init = .Init(iOperator, iExpresion)
+        End With
+        Exit Function
+    End If
+
+    Select Case iOperator
+        Case opEq, opNe
+            Expression = iExpresion
+
+        Case opLt, opLe
+            Expression = iExpresion
+
+        Case opGt, opGe
+            Expression = iExpresion
+
+        Case opLike, opNotLike
+            Expression = iExpresion
+
+        Case opiMatch, opiNotMatch
+            Set clsRegExp = NewRegExp(iExpresion, iIgnoreCase:=True)
+            Expression = iExpresion
+
+        Case opcMatch, opcNotMatch
+            Set clsRegExp = NewRegExp(iExpresion, iIgnoreCase:=False)
+            Expression = iExpresion
+
+        Case opIs, opIsNot
+            If Not VBA.IsObject(iExpresion) Then ThrowLINQ ArgumentException
+            Set Expression = iExpresion
+
+        Case Else
+            ThrowLINQ ArgumentException
+
+    End Select
+
+
+    Let Me.Operator = iOperator
+    Set Init = Me
+
+End Function
+
+Private Sub Class_Terminate()
+    Set clsRegExp = Nothing
+End Sub
+
+Private Function IFunc_Exec(iElement As Variant) As Variant
+    Dim rslt As Boolean
+
+    Select Case Me.Operator
+        Case opEq, opNe
+            rslt = ((iElement = Expression) = (Me.Operator = opEq))
+
+        Case opLt, opLe
+            rslt = (iElement < Expression)
+            If (rslt = False) And (Me.Operator = opLe) Then _
+                rslt = (iElement = Expression)
+
+        Case opGt, opGe
+            rslt = (iElement > Expression)
+            If (rslt = False) And (Me.Operator = opGe) Then _
+                rslt = (iElement = Expression)
+
+        Case opLike, opNotLike
+            rslt = ((iElement Like Expression) = (Me.Operator = opLike))
+
+        Case opiMatch, opiNotMatch
+            rslt = ((clsRegExp.Test(iElement)) = (Me.Operator = opiMatch))
+
+        Case opcMatch, opcNotMatch
+            rslt = ((clsRegExp.Test(iElement)) = (Me.Operator = opcNotMatch))
+
+        Case opIs, opIsNot
+            rslt = ((iElement Is Expression) = (Me.Operator = opIsNot))
+
+    End Select
+
+    Let IFunc_Exec = rslt
+
+End Function

src/Enumerable.cls

@@ -0,0 +1,48 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Enumerable"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
+Private clsCollection As VBA.Collection
+
+Public Function From(ByVal iEnumerable As Variant) As Enumerable
+Attribute From.VB_UserMemId = 0
+'Attribute From.VB_UserMemId = 0
+    If TypeOf iEnumerable Is VBA.Collection Then
+        Set clsCollection = iEnumerable
+    Else
+        Set clsCollection = New VBA.Collection
+        Dim iter As Variant
+        For Each iter In iEnumerable
+            clsCollection.Add iter
+        Next iter
+    End If
+
+    Set From = Me
+End Function
+
+Public Function Where(ByVal iPredicate As IFunc) As Enumerable
+    Dim newCol As VBA.Collection: Set newCol = New VBA.Collection
+
+    Dim iter As Variant
+    For Each iter In clsCollection
+        If iPredicate.Exec(iter) Then
+            newCol.Add iter
+        End If
+    Next iter
+
+    Set Where = LinqFrom(newCol)
+End Function
+
+
+Public Function GetEnumerator() As stdole.IEnumVARIANT
+Attribute GetEnumerator.VB_UserMemId = -4
+'Attribute GetEnumerator.VB_UserMemId = -4
+    Set GetEnumerator = clsCollection.[_NewEnum]
+End Function

src/PassThru.cls

@@ -0,0 +1,15 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "PassThru"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Implements IFunc
+Option Explicit
+
+Private Function IFunc_Exec(iElement As Variant) As Variant
+    AssignVal IFunc_Exec, iElement
+End Function

src/SpeedTest.bas

@@ -0,0 +1,77 @@
+Attribute VB_Name = "SpeedTest"
+Option Explicit
+
+Sub SpeedTest()
+    Dim buf As VBA.Collection
+
+    Const LOOP_COUNT& = 1000
+    Dim stTime!, i&
+
+    stTime = VBA.Timer
+    For i = 1 To LOOP_COUNT
+        Set buf = NormalVBA
+    Next i
+    Debug.Print "Normal", VBA.Timer - stTime
+
+    stTime = VBA.Timer
+    For i = 1 To LOOP_COUNT
+        Set buf = UseLinq
+    Next i
+    Debug.Print "Linq", VBA.Timer - stTime
+
+    stTime = VBA.Timer
+    For i = 1 To LOOP_COUNT
+        Set buf = DelayExec
+    Next i
+    Debug.Print "Delay", VBA.Timer - stTime
+
+End Sub
+
+Private Function NormalVBA() As VBA.Collection
+    Dim oCol As VBA.Collection
+    Set oCol = New VBA.Collection
+
+    Dim tWb As Excel.Workbook
+    Dim tSh As Object
+    For Each tWb In Excel.Workbooks
+        For Each tSh In tWb.Sheets
+            If tSh.Name Like "Sheet[0-9]" Then
+                oCol.Add tSh
+            End If
+        Next tSh
+    Next tWb
+    Set NormalVBA = oCol
+End Function
+
+Private Function UseLinq() As VBA.Collection
+    Set UseLinq = _
+            Enumerable.From(Workbooks) _
+            .SelectMany(CallByFunc.Init("Sheets", VbGet)) _
+            .Where(CallByFunc("Name", VbGet).SetChild(CompareOperator(opLike, "Sheet[0-9]"))) _
+            .ToCollection()
+
+End Function
+
+Private Function DelayExec() As VBA.Collection
+    Dim oCol As VBA.Collection
+    Set oCol = New VBA.Collection
+
+    Dim sheetsFunc As IFunc
+    Set sheetsFunc = CallByFunc("Sheets", VbGet)
+
+    Dim predict As IFunc
+    Set predict = CallByFunc("Name", VbGet).SetChild(CompareOperator(opLike, "Sheet[0-9]"))
+
+    Dim iter1 As Variant, iter2 As Variant
+    For Each iter1 In Enumerable.From(Workbooks)
+        For Each iter2 In sheetsFunc.Exec(iter1)
+            If predict.Exec(iter2) Then
+                oCol.Add iter2
+            End If
+        Next iter2
+    Next iter1
+
+
+    Set DelayExec = oCol
+End Function
+