Summary: So we can add a compact syntax for adding lambda predicates to filter VBA arrays using the FunctionDelegate framework. The latest version of FunctionDelegate framework is given below.
So I am quite pleased with the compact syntax now possible with the FunctionDelegate framework. So I will start with a sample. I hope this sample makes it very clear how we can write a small piece of filtering logic and just pack it into a string "x => x<5" of 8 characters (or a few more for other expressions)! This is compactness afforded by lambda expressions.
Option Explicit
Option Private Module
'* Tools->References
'* FnFactory.cls
'* FunctionDelegate.cls
Private Sub TestFilterByLambdaPredicate()
'* give me only numbers less than 5
Dim vFiltered2 As Variant
vFiltered2 = FilterByLambdaPredicate(Array(1, 2, 3, 4, 5, 6), "x => x<5")
Debug.Assert vFiltered2(0) = 1
Debug.Assert vFiltered2(1) = 2
Debug.Assert vFiltered2(2) = 3
Debug.Assert vFiltered2(3) = 4
'* give me only words that begin with 'b'
Dim vFiltered3 As Variant
vFiltered3 = FilterByLambdaPredicate(Array("foo", "bar", "barry", "baz"), "x => x.substring(0,1)==='b'")
Debug.Assert vFiltered3(0) = "bar"
Debug.Assert vFiltered3(1) = "barry"
Debug.Assert vFiltered3(2) = "baz"
End Sub
Private Function FilterByLambdaPredicate(ByVal vArray As Variant, ByVal sLambdaPredicate As String) As Variant
Dim fnPredicate As FunctionDelegate
Set fnPredicate = FnFactory.FnJsLamdaPredicate(sLambdaPredicate)
Dim sPredicateName As String
sPredicateName = fnPredicate.JavaScriptName
Debug.Assert FnFactory.ScriptControl.Run("predicateExists", sPredicateName) '* should do, here for debugging
FilterByLambdaPredicate = FnFactory.ScriptControl.Run("filterByPredicate", sPredicateName, vArray)
End Function
So to get predicates into the FunctionDelegate framework required some refactoring. Most importantly, FnFactory now maintains a singleton instance of the ScriptControl (though we still use a separate instance for a compilation test). Also, there is some extra code to warn about calling with too few arguments. We've chosen to add the Excel Application object to the global namespace and this allows callbacks using Application.Run. Also we've added argument type checking not just for the Javascript but for all function delegates which can be helpful for debugging and development.
So here is the code
The FnFactory class
Option Explicit
'* Tools References
'* MSScriptControl Microsoft Script Control 1.0 C:\Windows\SysWOW64\msscript.ocx
'* Scripting Microsoft Scripting Runtime C:\Windows\SysWOW64\scrrun.dll
'---------------------------------------------------------------------------------------
' Module : FnFactory
' DateTime : 06/02/2018 15:57
' Author : Simon
' Purpose : Contains factory methods to frees us from the syntactical constraints
' around the New keyword.
'
' Also for the javascript function delegates this class maintains a singleton
' instance of the ScriptControl so that different javascript functions can
' collaborate, such as filter by predicate.
'
'
' Deployment: Open a text editor and ensure the line reads "Attribute VB_PredeclaredId = True"
' so that one will not need to New this module!
'---------------------------------------------------------------------------------------
Private msLastError As String
Private moScriptControl As MSScriptControl.ScriptControl
Private mdicGlobalFunctions As New Scripting.Dictionary
Private mlJavaScriptCompileSavedErrNum As Long
Private msJavaScriptCompileSavedErrDesc As String
'---------------------------------------------------------------------------------------
' Procedure : ScriptControl
' DateTime : 16/02/2018 18:55
' Author : Simon
' Purpose : creates an instance of ScriptControl with core routines added and also dynamically added function
'---------------------------------------------------------------------------------------
' Arguments :
' [out,retval] : an instance of ScriptControl with core routines added and also dynamically added function
'
Public Property Get ScriptControl() As MSScriptControl.ScriptControl
Dim sProg As String
If moScriptControl Is Nothing Then
Set moScriptControl = New MSScriptControl.ScriptControl
moScriptControl.Language = "JScript"
moScriptControl.AddCode "function isArray(arr) { return arr.constructor.toString().indexOf('Array') > -1; }"
'* https://docs.microsoft.com/en-us/scripting/javascript/reference/vbarray-object-javascript
moScriptControl.AddCode "function fromVBArray(vbArray) { return new VBArray(vbArray).toArray();}"
'http://cwestblog.com/2011/10/24/javascript-snippet-array-prototype-tovbarray/
sProg = "Array.prototype.toVBArray = function() { " & _
" var dict = new ActiveXObject('Scripting.Dictionary'); " & _
" for(var i = 0, len = this.length; i < len; i++) " & _
" dict.add(i, this[i]); " & _
" return dict.Items(); " & _
"}; "
moScriptControl.AddCode sProg
'* add a singleton global variable then add some functions demonstrating how to use the square brackets surrounding
'* an identifier to reference a function
moScriptControl.Eval "var predicates={};"
moScriptControl.Eval "predicates['IsEven'] = function (num) { return ((num % 2) === 0); };"
moScriptControl.Eval "predicates['IsSmall'] = function (num) { return num < 5; };"
'* add a function that invokes the predicate, this is mainly error handling
'* I needed it during development to figure out the behaviour, probably too much code now
sProg = "function runPredicate(predicateName,n) { " & _
" var pred = predicates[predicateName]; " & _
" if (typeof pred !== 'undefined' && pred) { " & _
" return pred(n); " & _
" } " & _
"}"
moScriptControl.AddCode sProg
sProg = "function predicateExists(predicateName) { " & _
" var pred = predicates[predicateName]; " & _
" if (typeof pred !== 'undefined' && pred) { " & _
" return true; " & _
" } else { return false ; } " & _
"}"
moScriptControl.AddCode sProg
sProg = "function filterByPredicate(predicateName, vbNumbers) { " & _
" var filtered = []; var numbers=fromVBArray(vbNumbers); " & _
" var pred = predicates[predicateName]; " & _
" for (var i = 0; i < numbers.length; i++) { " & _
" if (pred(numbers[i])) { " & _
" filtered.push(numbers[i]); " & _
" } " & _
" } " & _
" return filtered.toVBArray(); " & _
"} "
moScriptControl.AddCode sProg
moScriptControl.AddObject "Application", Application
End If
Set ScriptControl = moScriptControl
End Property
'---------------------------------------------------------------------------------------
' Procedure : ResetScriptControl
' DateTime : 17/02/2018 16:18
' Author : Simon
' Purpose : Used for debugging, sometimes one needs a fresh start
'---------------------------------------------------------------------------------------
'
Public Sub ResetScriptControl()
Set moScriptControl = Nothing
Dim objDummy As Object
Set objDummy = ScriptControl
End Sub
'---------------------------------------------------------------------------------------
' Procedure : LastError
' DateTime : 14/02/2018 17:54
' Author : Simon
' Purpose : returns a copy of last error
'---------------------------------------------------------------------------------------
' Arguments :
' [out,retval] : returns a copy of last error
'
Public Function LastError() As String
LastError = msLastError
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnJavascript
' DateTime : 14/02/2018 17:50
' Author : Simon
' Purpose : Public method passes on inner core FnJavascript2
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sJavaScriptFunction : the JavaScript function source
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=Run(...' for returning an object
' [in] vArgTypeNames : (optional) array of argument typesname , used for type-checking warnings
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJavascript(ByVal sJavaScriptFunction As String, _
Optional ByVal bReturnTypeIsObject As Boolean, Optional vArgTypeNames As Variant) As FunctionDelegate
If IsMissing(vArgTypeNames) Then vArgTypeNames = Empty
Set FnJavascript = FnJavascript2(sJavaScriptFunction, bReturnTypeIsObject, "", "", vArgTypeNames)
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnJavascript
' DateTime : 14/02/2018 17:50
' Author : Simon
' Purpose :
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sJavaScriptFunction : the JavaScript function source
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=Run(...' for returning an object
' [in] sFunctionName : the javascript's function name
' [in] sQualifier : used to place function in non global namespace, e.g. predicates
' [in] vArgTypeNames : (optional) array of argument typesname , used for type-checking warnings
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Private Function FnJavascript2(ByVal sJavaScriptFunction As String, _
ByVal bReturnTypeIsObject As Boolean, ByVal sFunctionName As String, _
ByVal sQualifier As String, ByVal vArgTypeNames As Variant) As FunctionDelegate
Dim poProc As MSScriptControl.Procedure
'* attempt compilation in isolated script control instance
If Not CompileJavascript(sJavaScriptFunction, poProc) Then
msLastError = "#Failed to create javascript function delegate because compilation failed " & _
"with code (" & mlJavaScriptCompileSavedErrNum & ") and message '" & msJavaScriptCompileSavedErrDesc & "'"
Err.Raise vbObjectError, , msLastError
Else
'* now we know the javascript compiles we can proceed confidently
Dim oSC As MSScriptControl.ScriptControl
Set oSC = Me.ScriptControl
If LenB(sQualifier) = 0 Then
'* we add to the global namespace
If Not mdicGlobalFunctions.Exists(sJavaScriptFunction) Then
oSC.AddCode sJavaScriptFunction
Call mdicGlobalFunctions.Add(sJavaScriptFunction, 0)
End If
Else
'* we added the global variable found in sQualifier
oSC.Eval sQualifier & "['" & sFunctionName & "'] = " & sJavaScriptFunction
End If
Dim oNewFD As FunctionDelegate
Set oNewFD = New FunctionDelegate
oNewFD.JavaScriptFunction = sJavaScriptFunction
oNewFD.HasReturnValue = poProc.HasReturnValue
oNewFD.JavaScriptName = poProc.Name
oNewFD.NumArgs = poProc.NumArgs
If IsArray(vArgTypeNames) Then
oNewFD.ArgumentTypeNames = vArgTypeNames
End If
oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
Set FnJavascript2 = oNewFD
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : CompileJavascript
' DateTime : 16/02/2018 15:57
' Author : Simon
' Purpose : Compiles javascript into ScriptControl and detect errors, also returns a
' reference to the newly created procedure from which the function name
' can be found
'
' Uses own instance of ScriptControl for isolation.
'
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sJavaScriptFunction : a full javascript function expression
' [in,out] poNewestProc : the newly created procedure (if compiled)
' [out,retval] : boolean, whether or not the function compiles
'
Private Function CompileJavascript(ByVal sJavaScriptFunction As String, _
ByRef poNewestProc As MSScriptControl.Procedure) As Boolean
Static oSC As MSScriptControl.ScriptControl
Set oSC = New MSScriptControl.ScriptControl
oSC.Language = "JScript"
On Error Resume Next
oSC.AddCode sJavaScriptFunction
msJavaScriptCompileSavedErrDesc = Err.Description
mlJavaScriptCompileSavedErrNum = Err.Number
On Error GoTo 0
If mlJavaScriptCompileSavedErrNum = 0 Then
Set poNewestProc = oSC.Procedures.Item(oSC.Procedures.Count)
CompileJavascript = True
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnJsLamda
' DateTime : 14/02/2018 17:56
' Author : Simon
' Purpose : Takes a lambda expression and rewrites it as a javascript function and passes
' it to create a javascript function delegate
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sJsLamda : the Lambda expression (uses JavaScript syntax underlying)
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=Run(...' for returning an object
' [in] vArgTypeNames : (optional) array of argument typesname , used for type-checking warnings
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJsLamda(ByVal sJsLamda As String, Optional ByVal bReturnTypeIsObject As Boolean, _
Optional ByVal vArgTypeNames As Variant) As FunctionDelegate
Dim sJavascript As String
sJavascript = RewriteLamdaAsFullJavascriptFunction(sJsLamda, True)
Set FnJsLamda = FnJavascript2(sJavascript, bReturnTypeIsObject, "", "", vArgTypeNames)
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnJsLamdaPredicate
' DateTime : 14/02/2018 17:56
' Author : Simon
' Purpose : Takes a lambda expression and rewrites it as a javascript function and
'
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sJsLamda : the Lambda expression (uses JavaScript syntax underlying)
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=Run(...' for returning an object
' [in] vArgTypeNames : (optional) array of argument typesname , used for type-checking warnings
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJsLamdaPredicate(ByVal sJsLamda As String, Optional ByVal bReturnTypeIsObject As Boolean, _
Optional ByVal vArgTypeNames As Variant) As FunctionDelegate
Dim sJavascript As String, psHash As String
sJavascript = RewriteLamdaAsFullJavascriptFunction(sJsLamda, True, psHash)
Set FnJsLamdaPredicate = FnJavascript2(sJavascript, bReturnTypeIsObject, psHash, "predicates", vArgTypeNames)
End Function
'---------------------------------------------------------------------------------------
' Procedure : RewriteLamdaAsFullJavascriptFunction
' DateTime : 14/02/2018 17:56
' Author : Simon
' Purpose : Parses a lambda expression and rewrites it as a javascript function
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sJsLamda : the Lambda expression (uses JavaScript syntax underlying)
' [in] bLabelWithHash : whether or not to label the resulting function, predicates differ
' [in,out] psHash : if not labelling with hash pass out hash to caller
' [out,retval] : an equivalent fully defined Javascript function
'
Private Function RewriteLamdaAsFullJavascriptFunction(ByVal sJsLamda As String, ByVal bLabelWithHash As Boolean, _
Optional ByRef psHash As Variant) As String
If Len(sJsLamda) = 0 Then Err.Raise vbObjectError, "", "#Error null sJsLamda!"
If InStr(1, sJsLamda, "function", vbTextCompare) > 0 Then Err.Raise vbObjectError, "", _
"#Found function keyword suggesting it is a function definition and not a lambda!"
Dim lArrowAt As Long
lArrowAt = VBA.InStr(1, sJsLamda, "=>", vbTextCompare)
If lArrowAt = 0 Then Err.Raise vbObjectError, "", _
"#Could not find arrow operator '=>' in sJsLamda '" & sJsLamda & "'!"
If VBA.InStr(lArrowAt + 1, sJsLamda, "=>", vbTextCompare) > 0 Then Err.Raise vbObjectError, "", _
"#Found more than one arrow operator '=>' in sJsLamda '" & sJsLamda & "'!"
Dim vSplit As Variant
vSplit = VBA.Split(sJsLamda, "=>")
Static dicHasher As New Scripting.Dictionary
Dim sHash As String
sHash = "f" & CStr(dicHasher.HashVal(sJsLamda))
If Not IsMissing(psHash) Then psHash = sHash
Dim sGivenFunctionNameAndArgs As String
If bLabelWithHash Then
sGivenFunctionNameAndArgs = "function " & sHash & "(" & Trim(vSplit(0)) & ") "
Else
sGivenFunctionNameAndArgs = "function (" & Trim(vSplit(0)) & ") "
End If
Dim lSemiColonsAfterArrow As Long
lSemiColonsAfterArrow = CountOccurrences(vSplit(1), ";")
If lSemiColonsAfterArrow <> CountOccurrences(sJsLamda, ";") Then Err.Raise vbObjectError, , _
"#Semicolons should only appear after arrow in sJsLamda '" & sJsLamda & "'!"
If lSemiColonsAfterArrow = 0 Then
Dim sFunctionBody As String
sFunctionBody = "{ return " & Trim(vSplit(1)) & "; }"
Else
'* we have a multi statement function so we have to splice in the return keyword
Dim vSplitOnSemiColons As Variant
vSplitOnSemiColons = VBA.Split(vSplit(1), ";")
vSplitOnSemiColons(UBound(vSplitOnSemiColons)) = " return " & vSplitOnSemiColons(UBound(vSplitOnSemiColons)) & ";"
Dim sRejoined As String
sRejoined = VBA.Join(vSplitOnSemiColons, ";")
sFunctionBody = "{ " & Trim(sRejoined) & " }"
End If
RewriteLamdaAsFullJavascriptFunction = sGivenFunctionNameAndArgs & sFunctionBody
End Function
'---------------------------------------------------------------------------------------
' Procedure : CountOccurrences
' DateTime : 14/02/2018 17:55
' Author : Simon
' Purpose :
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sText : the string in which to search
' [in] sChar : the character(s) for which to search
' [out,retval] : the number of occurences of the character(s)
'
Private Function CountOccurrences(ByVal sText As String, ByVal sChar As String) As Long
Dim lCount As Long: lCount = 0
Dim lCharAt As Long
lCharAt = VBA.InStr(1, sText, sChar, vbTextCompare)
While lCharAt > 0
DoEvents
lCount = lCount + 1
lCharAt = VBA.InStr(lCharAt + 1, sText, sChar, vbTextCompare)
Wend
CountOccurrences = lCount
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnAppRun
' DateTime : 05/02/2018 14:05
' Author : Simon
' Purpose : A factory method to create a FunctionDelegate containing enough info
' to pass to Application.Run(.. , .. , .. , ...)
' Using a factory method frees us from the syntactical constraints
' around the New keyword
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sMacro : the name of macro passed to Application.Run
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=Application.Run(...' for returning an object
' [in] lNumArgs : (optional) the expected number of arguments, used to give warnings of 'mis-call'.
' [in] vArgTypeNames : (optional) array of argument typesname , used for type-checking warnings
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnAppRun(ByVal sMacro As String, Optional ByVal bReturnTypeIsObject As Boolean, _
Optional ByVal lNumArgs As Variant, Optional ByRef vArgTypeNames As Variant) As FunctionDelegate
Dim oNewFD As FunctionDelegate
Set oNewFD = New FunctionDelegate
If IsArray(vArgTypeNames) Then
oNewFD.ArgumentTypeNames = vArgTypeNames
End If
oNewFD.IsAppRun = True
oNewFD.AppRunMacro = sMacro
oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
If Not IsMissing(lNumArgs) Then
If IsNumeric(lNumArgs) Then
oNewFD.NumArgs = lNumArgs
End If
End If
'oNewFD.mvArgs = vargs
Set FnAppRun = oNewFD
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnCallByName
' DateTime : 06/02/2018 15:50
' Author : Simon
' Purpose : A factory method to create a FunctionDelegate containing enough info
' to pass to VBA.CallByName(.. , .. , .. , ...)
' Using a factory method frees us from the syntactical constraints
' around the New keyword
'---------------------------------------------------------------------------------------
' Arguments :
' [in] oCallByNameTarget : the object (class instance) on whom we want to call the method
' [in] sMacro : the name of method we want to call
' [in] eCallByNameType : necessary to specify one of {VbSet, VbMethod, VbLet, VbGet}
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=VBA.CallByName(...' for returning an object
' [in] lNumArgs : (optional) the expected number of arguments, used to give warnings of 'mis-call'.
' [in] vArgTypeNames : (optional) array of argument typesname , used for type-checking warnings
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnCallByName(ByVal oCallByNameTarget As Object, ByVal sMacro As String, _
ByVal eCallByNameType As VbCallType, Optional ByVal bReturnTypeIsObject As Boolean, _
Optional ByVal lNumArgs As Variant, Optional ByRef vArgTypeNames As Variant) As FunctionDelegate
Dim oNewFD As FunctionDelegate
Set oNewFD = New FunctionDelegate
If IsArray(vArgTypeNames) Then
oNewFD.ArgumentTypeNames = vArgTypeNames
End If
oNewFD.IsAppRun = False
Set oNewFD.CallByNameTarget = oCallByNameTarget
oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
oNewFD.CallByNameType = eCallByNameType
oNewFD.AppRunMacro = sMacro
If Not IsMissing(lNumArgs) Then
If IsNumeric(lNumArgs) Then
oNewFD.NumArgs = lNumArgs
End If
End If
'oNewFD.mvArgs = vargs
Set FnCallByName = oNewFD
End Function
'---------------------------------------------------------------------------------------
' Procedure : ScriptControlsProcedures
' DateTime : 17/02/2018 16:19
' Author : Simon
' Purpose : Used for debugging. Returns a dictionary with the names of the procedures
' currently loaded in the ScriptControl
'---------------------------------------------------------------------------------------
' Arguments :
' [out,retval] : returns a dictionary with the names of the procedures
'
Friend Function ScriptControlsProcedures() As Scripting.Dictionary
Dim dicProcs As Scripting.Dictionary
Set dicProcs = New Scripting.Dictionary
Dim oSC As MSScriptControl.ScriptControl
Set oSC = FnFactory.ScriptControl
Dim lProcLoop As Long
For lProcLoop = 1 To oSC.Procedures.Count
Dim oProcLoop As MSScriptControl.Procedure
Set oProcLoop = oSC.Procedures.Item(lProcLoop)
dicProcs.Add oProcLoop.Name, oProcLoop.NumArgs
Next lProcLoop
Set ScriptControlsProcedures = dicProcs
End Function
The FunctionDelegate class
Option Explicit
'* Tools References
'* MSScriptControl Microsoft Script Control 1.0 C:\Windows\SysWOW64\msscript.ocx
'* Scripting Microsoft Scripting Runtime C:\Windows\SysWOW64\scrrun.dll
'---------------------------------------------------------------------------------------
' Module : FunctionDelegate
' DateTime : 06/02/2018 16:04
' Author : Simon
' Purpose : Contains enough information to call a function either using
' (a) Application.Run() if function lives in a standard module or
' (b) VBA.CallByName() if function lives in a class instance (object)
' (c) MSScriptControl.ScriptControl.Run() is given a javascript function
' (d) MSScriptControl.ScriptControl.Run() is given a lambda function
'
' Uses the FnFactory class for instantiation of this class.
'---------------------------------------------------------------------------------------
Private msAppRunMacro As String
Private mobjCallByNameTarget As Object
Private meCallByNameType As VbCallType
Private mbIsAppRun As Boolean
Private mbReturnTypeIsObject As Boolean
Private mvArgumentTypeNames As Variant
'* Added 14th Feb 2018
Private msJavaScriptFunction As String
Private msJavaScriptName As String
Private mbHasReturnValue As Variant '* Empty signifies unset
Private mlNumArgs As Variant '* Empty signifies unset
Public Property Get ArgumentTypeNames() As Variant
ArgumentTypeNames = mvArgumentTypeNames
End Property
Public Property Let ArgumentTypeNames(ByVal rhs As Variant)
mvArgumentTypeNames = rhs
End Property
Public Property Get NumArgs() As Long
NumArgs = mlNumArgs
End Property
Public Property Let NumArgs(ByVal lNumArgs As Long)
mlNumArgs = lNumArgs
End Property
Public Property Get HasReturnValue() As Boolean
HasReturnValue = mbHasReturnValue
End Property
Public Property Let HasReturnValue(ByVal bHasReturnValue As Boolean)
mbHasReturnValue = bHasReturnValue
End Property
Public Property Get JavaScriptFunction() As String
JavaScriptFunction = msJavaScriptFunction
End Property
Public Property Let JavaScriptFunction(ByVal sJavaScriptFunction As String)
msJavaScriptFunction = sJavaScriptFunction
End Property
Public Property Get JavaScriptName() As String
JavaScriptName = msJavaScriptName
End Property
Public Property Let JavaScriptName(ByVal sJavaScriptName As String)
msJavaScriptName = sJavaScriptName
End Property
Public Property Get ReturnTypeIsObject() As Boolean
ReturnTypeIsObject = mbReturnTypeIsObject
End Property
Public Property Let ReturnTypeIsObject(ByVal bReturnTypeIsObject As Boolean)
mbReturnTypeIsObject = bReturnTypeIsObject
End Property
Public Property Get IsAppRun() As Boolean
IsAppRun = mbIsAppRun
End Property
Public Property Let IsAppRun(ByVal bIsAppRun As Boolean)
mbIsAppRun = bIsAppRun
End Property
Public Property Get CallByNameType() As VbCallType
CallByNameType = meCallByNameType
End Property
Public Property Let CallByNameType(ByVal eCallByNameType As VbCallType)
meCallByNameType = eCallByNameType
End Property
Public Property Get CallByNameTarget() As Object
Set CallByNameTarget = mobjCallByNameTarget
End Property
Public Property Set CallByNameTarget(ByVal objCallByNameTarget As Object)
Set mobjCallByNameTarget = objCallByNameTarget
End Property
Public Property Get AppRunMacro() As String
AppRunMacro = msAppRunMacro
End Property
Public Property Let AppRunMacro(ByVal sAppRunMacro As String)
msAppRunMacro = sAppRunMacro
End Property
'---------------------------------------------------------------------------------------
' Procedure : Run
' DateTime : 06/02/2018 16:01
' Author : Simon
' Purpose : This runs/executes/calls the function. Deployed correctly one can omit
' .Run in the calling line see unit tests for example
'
' Deployment: *** need to ensure that this has the line "Attribute Item.VB_UserMemId = 0"
' to make it default ***
'---------------------------------------------------------------------------------------
' Arguments :
' vargs() : a variable list of arguments which we'll pass on to Application.Run()
' or VBA.CallByName()
'
Public Function Run(ParamArray vargs() As Variant)
Dim lArgCount As Long
lArgCount = UBound(vargs) - LBound(vargs) + 1
Dim dicWarnings As Scripting.Dictionary
Set dicWarnings = New Scripting.Dictionary
If Not IsEmpty(mlNumArgs) Then
If Me.NumArgs <> lArgCount Then
dicWarnings.Add "@Warning calling wrong number of arguments, expecting " & _
mlNumArgs & " but got " & lArgCount & "!", 0
End If
End If
If IsArray(mvArgumentTypeNames) Then
Dim lNumberOfArgsToCheck As Long
lNumberOfArgsToCheck = VBA.IIf(Me.NumArgs < lArgCount, Me.NumArgs, lArgCount)
Dim lArgCheckLoop As Long
For lArgCheckLoop = 1 To lNumberOfArgsToCheck
If Len(mvArgumentTypeNames(lArgCheckLoop)) > 0 Then
If StrComp(mvArgumentTypeNames(lArgCheckLoop), TypeName(vargs(lArgCheckLoop - 1)), vbTextCompare) <> 0 Then
dicWarnings.Add "@Warning, argument type mismatch for argument " & lArgCheckLoop & _
", expecting '" & mvArgumentTypeNames(lArgCheckLoop) & "' but is '" & _
TypeName(vargs(lArgCheckLoop - 1)) & " instead!", 0
End If
End If
Next
End If
If dicWarnings.Count > 0 Then Debug.Print Join(dicWarnings.Keys)
If mbIsAppRun Then
If lArgCount = 0 Then
If mbReturnTypeIsObject Then
Set Run = Application.Run(msAppRunMacro)
Else
Run = Application.Run(msAppRunMacro)
End If
ElseIf lArgCount = 1 Then
If mbReturnTypeIsObject Then
Set Run = Application.Run(msAppRunMacro, vargs(0))
Else
Run = Application.Run(msAppRunMacro, vargs(0))
End If
ElseIf lArgCount = 2 Then
If mbReturnTypeIsObject Then
Set Run = Application.Run(msAppRunMacro, vargs(0), vargs(1))
Else
Run = Application.Run(msAppRunMacro, vargs(0), vargs(1))
End If
Else
'requires more lines to handle multiple arguments,
'a bit ugly so will do later
End If
ElseIf Not mobjCallByNameTarget Is Nothing Then
If lArgCount = 0 Then
If mbReturnTypeIsObject Then
Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType)
Else
Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType)
End If
ElseIf lArgCount = 1 Then
If mbReturnTypeIsObject Then
Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0))
Else
Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0))
End If
ElseIf lArgCount = 2 Then
If mbReturnTypeIsObject Then
Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0), vargs(1))
Else
Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0), vargs(1))
End If
Else
'requires more lines to handle multiple arguments,
'a bit ugly so will do later
End If
ElseIf LenB(msJavaScriptFunction) > 0 Then
'* Tools References
'* MSScriptControl Microsoft Script Control 1.0 C:WindowsSysWOW64msscript.ocx
Dim oSC As MSScriptControl.ScriptControl
Set oSC = FnFactory.ScriptControl '* use the same global instance
If lArgCount = 0 Then
If mbReturnTypeIsObject Then
Set Run = oSC.Run(Me.JavaScriptName, msAppRunMacro)
Else
Run = oSC.Run(Me.JavaScriptName, msAppRunMacro)
End If
ElseIf lArgCount = 1 Then
If mbReturnTypeIsObject Then
Set Run = oSC.Run(Me.JavaScriptName, vargs(0))
Else
Dim dic As Scripting.Dictionary
Set dic = FnFactory.ScriptControlsProcedures
Debug.Assert dic.Exists(Me.JavaScriptName)
Run = oSC.Run(Me.JavaScriptName, vargs(0))
End If
ElseIf lArgCount = 2 Then
If mbReturnTypeIsObject Then
Set Run = oSC.Run(Me.JavaScriptName, vargs(0), vargs(1))
Else
Run = oSC.Run(Me.JavaScriptName, vargs(0), vargs(1))
End If
Else
'requires more lines to handle multiple arguments,
'a bit ugly so will do later
End If
End If
If IsArray(mvArgumentTypeNames) Then
If LenB(mvArgumentTypeNames(0)) > 0 Then
If StrComp(mvArgumentTypeNames(0), TypeName(Run), vbTextCompare) <> 0 Then
Debug.Print "@Warning, return type mismatch, expecting '" & _
mvArgumentTypeNames(0) & "' but is '" & TypeName(Run) & " instead!"
End If
End If
End If
End Function
A test module
Option Explicit
Option Private Module
Private Sub TestFNFactory_All()
Test_Application
TestFnJsLamda_PassXml
TestFNJavascript
End Sub
Private Sub Test_Application()
Dim oFnFactory As FnFactory
Set oFnFactory = New FnFactory
oFnFactory.ResetScriptControl
Dim fn As FunctionDelegate
Set fn = FnFactory.FnJavascript("function Log2( msg) { Application.Run('Log',msg) ; }", False, Array("", "String"))
Call fn("hi")
Dim fn2 As FunctionDelegate
Set fn2 = FnFactory.FnJsLamda("x => Application.Run('Log',x) ", False, Array("", "String"))
' 'Call fn2("log this")
Call fn2(1)
End Sub
Sub Log(ByVal sMsg As String)
Debug.Print sMsg
End Sub
Private Sub TestFnJsLamda_PassXml()
Dim oFnFactory As FnFactory
Set oFnFactory = New FnFactory
oFnFactory.ResetScriptControl
Dim xmlDom As MSXML2.DOMDocument60
Set xmlDom = New MSXML2.DOMDocument60
'* Debug.Print TypeName(xmlDom) prints "DOMDocument60"
xmlDom.LoadXML "<foo><bar/><bar/><bar/><bar/></foo>"
Dim fn As FunctionDelegate
Set fn = FnFactory.FnJsLamda("xml => xml.documentElement.childNodes.length < 4 ", False, Array("Boolean", "DOMDocument60"))
Debug.Assert fn(xmlDom) = False
End Sub
Private Sub TestFNJavascript()
'End
Dim oFnDelegate As FunctionDelegate
Set oFnDelegate = FnFactory.FnJavascript("function foo(bar) { return bar===1; }", False, Array("Boolean", "Integer"))
Debug.Assert oFnDelegate.JavaScriptFunction = "function foo(bar) { return bar===1; }"
Debug.Assert oFnDelegate.JavaScriptName = "foo"
'Stop
Debug.Assert oFnDelegate.Run(0) = False
Debug.Assert oFnDelegate.Run(1) = True
Dim oFnDelegate2 As FunctionDelegate
Set oFnDelegate2 = FnFactory.FnJavascript("function foo2(x) { return Math.pow(x,2)-4*x-5; }", False, Array("", "Integer"))
Debug.Assert oFnDelegate2.Run(5) = 0 'root
Debug.Assert oFnDelegate2.Run(-1) = 0 'root
Debug.Assert oFnDelegate2.Run(1) = -8
End Sub
No comments:
Post a Comment