VBA - ScriptControl - Predicates in JScript part 2

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

VBA - ScriptControl - Predicates in JScript part 1

Summary: Predicates are functions which return booleans and are useful for filtering. Here we show how housing a predicate in a global singleton variable makes it available to a filtering function.

Continuing our JScript series, we give how to pass a Javascript delegate to another Javascript function to effect filtering.

After inventing lambda expressions and delegates for VBA using JScript we look to the next cool feature, predicates. Filtering logic technologies (such as LINQ) often allow thew user to supply a predicate, which is a function that returns true or false. A classic example is using a predicate to filter an array, so numbers less than 5 or even numbers only.

Implementing this in JScript in the ScriptControl in VBA was a little challenging because it is limited to Ecmascript 3. But here in part one I can give a block code below which demonstrates how it is possible, in part two I will integrate it into my FunctionDelegate framework and we will see a nice compact syntax .

So the key lines of code to make this fly declare a global singleton variable and then add the functions as properties identified by strings. Instead of using the ScriptControl's AddCode method I use the Eval method (it wouldn't work otherwise).

    '* add a singleton global variable then add some functions demonstrating how to use the square brackets surrounding
    '* an identifier to reference a function
    oSC.Eval "var predicates={};"
    oSC.Eval "predicates['IsEven'] = function (num) { return ((num % 2) === 0); };"
    oSC.Eval "predicates['IsSmall'] = function (num) { return num < 5; };"

Then to retrieve and execute the predicate it is simply the following where predicateName is a string containing predicate name such as 'IsEven' or 'IsSmall'... (though in reality we add some error checking in case we're asking for a predicate that wasn't added) ...

var pred = predicates[predicateName]; 
return pred(n);

So below is a big block code which demonstrates it working. The IsEven() and IsSmall() are kind of hardcoded. In contrast, the IsOdd() predicate is added in a parameterised fashion and you could see how we could break this out and expose a function to the outside world. Then underneath can be found the filterByPredicate() function which takes a predicate name and an array and filters the array using the requested predicate. Lastly, at the bottom one can find test code calling into filterByPredicate() with the three different predicates.

In part two, I will fold these concepts into the FunctionDelegate framework I have developed

Option Explicit
Option Private Module

'* Tools->References
'*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx

Private Sub ExperimentWithPredicates()

    Dim sProg As String

    Dim oSC As MSScriptControl.ScriptControl
    Set oSC = New MSScriptControl.ScriptControl
    oSC.Language = "JScript"
    
    '* https://docs.microsoft.com/en-us/scripting/javascript/reference/vbarray-object-javascript
    oSC.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();                                                                                         " & _
            "};                                                                                                              "
    oSC.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
    oSC.Eval "var predicates={};"
    oSC.Eval "predicates['IsEven'] = function (num) { return ((num % 2) === 0); };"
    oSC.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);                                                                                          " & _
            "   }                                                                                                            " & _
            "}"
    oSC.AddCode sProg
    
    
    '* quickly test these
    Debug.Assert oSC.Run("runPredicate", "IsEven", 8)
    Debug.Assert Not oSC.Run("runPredicate", "IsEven", 7)
    Debug.Assert oSC.Run("runPredicate", "IsSmall", 1)
    Debug.Assert Not oSC.Run("runPredicate", "IsSmall", 6)
    
    
    '* just to prove we could do this dynamically I give this example
    Dim sPredicateName As String
    sPredicateName = "IsOdd"
    
    Dim sPredicateSource As String
    sPredicateSource = "function (num) { return ((num % 2) === 1); }"
    
    oSC.Eval "predicates['" & sPredicateName & "'] = " & sPredicateSource & ";"
    
    '* test this as well
    Debug.Assert oSC.Run("runPredicate", sPredicateName, 7)
    Debug.Assert Not oSC.Run("runPredicate", sPredicateName, 8)


    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();                                                                                " & _
            "}                                                                                                               "
    oSC.AddCode sProg
    

    
    Dim vFiltered1 As Variant
    vFiltered1 = oSC.Run("filterByPredicate", "IsEven", Array(1, 2, 3, 4, 5, 6))
    Debug.Assert vFiltered1(0) = 2
    Debug.Assert vFiltered1(1) = 4
    Debug.Assert vFiltered1(2) = 6
    
    Dim vFiltered2 As Variant
    vFiltered2 = oSC.Run("filterByPredicate", "IsSmall", Array(1, 2, 3, 4, 5, 6))
    Debug.Assert vFiltered2(0) = 1
    Debug.Assert vFiltered2(1) = 2
    Debug.Assert vFiltered2(2) = 3
    Debug.Assert vFiltered2(3) = 4
    
    
    Dim vFiltered3 As Variant
    vFiltered3 = oSC.Run("filterByPredicate", "IsOdd", Array(1, 2, 3, 4, 5, 6))
    Debug.Assert vFiltered3(0) = 1
    Debug.Assert vFiltered3(1) = 3
    Debug.Assert vFiltered3(2) = 5

    'Stop
End Sub

VBA - Javascript - Passing arrays to and fro

Summary: Javascript arrays differ from VBA variant arrays so one needs some conversion logic, here we give it.

VBA (like VB6) has its own type of array called a SafeArray; safe because it does bounds checking unlike C++ arrays. Additionally, SafeArrays can be used in For Each Next loops so often I prefer to use them. Sadly, Javascript cannot direct read a Safearray, equally accessing Javascript arrays from VBA is quite painful (use CallByName, vbGet, with a stringified index number). We need some conversion logic both to and fro to help us along.

In the following module, one can find

• isArray(), a function to test for an array (a great many array tests on the Internet won't run in the ScriptControl because limited to Ecmascript 3)
• fromArray(), a function to convert a VB array to a javascript array .
• toVBArray (), a method added to the Array prototype (so is inherited by all arrays) that allows the conversion to a VB safearray.
• Some test code filterOdd() demonstrating the above.

Option Explicit

'* Tools->References
'*   MSScriptControl        Microsoft Script Control 1.0        C:\Windows\SysWOW64\msscript.ocx


Private Sub TestJavascriptArraysToAndFro()

    Dim sProg As String

    Dim oSC As MSScriptControl.ScriptControl
    Set oSC = New MSScriptControl.ScriptControl
    oSC.Language = "JScript"
    oSC.AddCode "function isArray(arr) {  return arr.constructor.toString().indexOf('Array') > -1; }"
    
    '* https://docs.microsoft.com/en-us/scripting/javascript/reference/vbarray-object-javascript
    oSC.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();                                                                                         " & _
            "};                                                                                                              "
    
    oSC.AddCode sProg
    
    sProg = "function filterOdd(vbArray) {                                                                                   " & _
            "    var numbers = new VBArray(vbArray).toArray();                                                               " & _
            "    var filtered = [];                                                                                          " & _
            "    if (isArray(numbers)) {                                                                                     " & _
            "        for (var i = 0; i < numbers.length; i++) {                                                              " & _
            "            if (numbers[i] % 2 === 1 ) {                                                                        " & _
            "                filtered.push(numbers[i]);                                                                      " & _
            "            }                                                                                                   " & _
            "        }                                                                                                       " & _
            "    }                                                                                                           " & _
            "    return filtered.toVBArray();                                                                                " & _
            "}                                                                                                               "
    
    oSC.AddCode sProg

    Dim vFiltered As Variant
    vFiltered = oSC.Run("filterOdd", Array(1, 2, 3, 4, 5, 6))

    Debug.Assert vFiltered(0) = 1
    Debug.Assert vFiltered(1) = 3
    Debug.Assert vFiltered(2) = 5

    Stop
End Sub

VBA - Javascript - source code to VBA string formatter

Summary: A nice little utility that reads some javascript in a file and formats it into a VBA string defeinition ready to supplied to the ScriptControl

So, writing a number of these posts I have to say that editing the Javascript in a VBA string is quite painful. So, I found myself switching over to Visual Studio running a Node.js application and editing code there, to bring it back into VBA we need to wrap quotes around it and have line continuations characters to break the string definition over several lines. After doing this manually I saw the value in writing some helpful code to automate it it, and so it is give below. First though, some sample output where one can see the code formatted into a block

    sProg = "function filterOdd(vbArray) {                                                                                   " & _
            "    var numbers = new VBArray(vbArray).toArray();                                                               " & _
            "    var filtered = [];                                                                                          " & _
            "    if (isArray(numbers)) {                                                                                     " & _
            "        for (var i = 0; i < numbers.length; i++) {                                                              " & _
            "            if (numbers[i] % 2 === 1 ) {                                                                        " & _
            "                filtered.push(numbers[i]);                                                                      " & _
            "            }                                                                                                   " & _
            "        }                                                                                                       " & _
            "    }                                                                                                           " & _
            "    return filtered.toVBArray();                                                                                " & _
            "}                                                                                                               "

The modJavascriptSourceToVBAString standard module

'---------------------------------------------------------------------------------------
' Module    : modJavascriptSourceToVBAString
' DateTime  : 15/02/2018 16:55
' Author    : Simon
' Purpose   : Use ShellNotepadTempFile() to shell Notepad to a working temporary file where
'             one can paste in javascript and then run ConvertToVBAString() to convert to
'             something one can paste into VBA code.
'
'             For previously created strings that also needs formatting use Reformat()
'
'---------------------------------------------------------------------------------------
Option Explicit

'* Tools->References
'*   Scripting              Microsoft Scripting Runtime         C:\Windows\SysWOW64\scrrun.dll
'*   IWshRuntimeLibrary     Windows Script Host Object Model    C:\Windows\SysWOW64\wshom.ocx


Private fso As New Scripting.FileSystemObject

Private Const clPAD As Long = 112

Private Const mcsJScriptFile As String = "JScriptFormatter.txt"


'---------------------------------------------------------------------------------------
' Procedure : ShellNotepadTempFile
' DateTime  : 15/02/2018 16:45
' Author    : Simon
' Purpose   : Opens Notepad on our working file
'---------------------------------------------------------------------------------------
'
Private Sub ShellNotepadTempFile()
    
    Dim sJScriptFilePath As String
    sJScriptFilePath = JScriptFileFullPath
    
    If Not fso.FileExists(sJScriptFilePath) Then
        
        fso.CreateTextFile(sJScriptFilePath).Write _
            "//paste javascript here, save and then run ConvertToVBAString()"
    
    End If
    
    Dim oShell32 As IWshRuntimeLibrary.WshShell
    Set oShell32 = New IWshRuntimeLibrary.WshShell
    oShell32.Run "notepad.exe " & sJScriptFilePath
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ConvertToVBAString
' DateTime  : 15/02/2018 16:42
' Author    : Simon
' Purpose   : Reads the file containing the Javascript and converts to a VBA string definition
'---------------------------------------------------------------------------------------
'
Private Sub ConvertToVBAString()

    Dim vLinesOriginal As Variant, plLineCount As Long
    vLinesOriginal = ReadFilesIntoArray(JScriptFileFullPath, plLineCount)

    Dim vLines As Variant
    vLines = vLinesOriginal
    
    Dim lLineLoop As Variant
    For lLineLoop = 0 To plLineCount - 1
        
        vLines(lLineLoop) = VBALine(PadAndQuoteJavascript(vLines(lLineLoop), clPAD), lLineLoop, plLineCount)
    
    Next
    Debug.Print Join(vLines, vbNewLine)
    'Stop
End Sub


'---------------------------------------------------------------------------------------
' Procedure : Reformat
' DateTime  : 15/02/2018 16:50
' Author    : Simon
' Purpose   : Reads the file with a VBA string definition of javascript and reformats it
'---------------------------------------------------------------------------------------
'
Private Sub Reformat()
    Dim vLinesOriginal As Variant, plLineCount As Long
    vLinesOriginal = ReadFilesIntoArray(JScriptFileFullPath, plLineCount)

    Dim vLines As Variant
    vLines = vLinesOriginal

    Dim lLineLoop As Variant
    For lLineLoop = 0 To plLineCount - 1
    
        vLines(lLineLoop) = Trim(vLines(lLineLoop))
        
        Const csTrail As String = """ & _"
        Const csLead0 As String = "sProg = """
        
        If StrComp(Left$(vLines(lLineLoop), Len(csLead0)), csLead0, vbTextCompare) = 0 And _
                                    StrComp(Right$(vLines(lLineLoop), Len(csTrail)), csTrail) = 0 Then
            
            Dim vSplit1 As Variant
            vSplit1 = VBA.Split(vLines(lLineLoop), csTrail)(0)
            
            Dim vSplit2 As Variant
            vSplit2 = VBA.Split(vSplit1, csLead0)(1)
            
                    
        ElseIf Left$(vLines(lLineLoop), 1) = """" And _
                                    StrComp(Right$(vLines(lLineLoop), Len(csTrail)), csTrail) = 0 Then
            
            vSplit2 = Mid$(vLines(lLineLoop), 2, Len(vLines(lLineLoop)) - Len(csTrail) - 1)
            
        ElseIf Left$(vLines(lLineLoop), 1) = """" And Right$(vLines(lLineLoop), 1) = """" Then
            vSplit2 = Mid$(vLines(lLineLoop), 2, Len(vLines(lLineLoop)) - 2)
        Else
            'bug
            Stop
        End If
    
        vLines(lLineLoop) = VBALine(PadAndQuoteJavascript(vSplit2, clPAD), lLineLoop, plLineCount)

    Next
    
    Debug.Print Join(vLines, vbNewLine)
    'Stop


End Sub





'---------------------------------------------------------------------------------------
' ____ ___   __  .__.__  .__  __           ___________                   __  .__
'|    |   _/  |_|__|  | |__|/  |_ ___.__. _   _____/_ __  ____   _____/  |_|__| ____   ____   ______
'|    |   /   __  |  | |     __<   |  |  |    __)|  |  /    _/ ___   __  |/  _  /     /  ___/
'|    |  /  |  | |  |  |_|  ||  |  ___  |  |      |  |  /   |    ___|  | |  (  <_> )   |  \___ 
'|______/   |__| |__|____/__||__|  / ____|  ___  / |____/|___|  /___  >__| |__|____/|___|  /____  >
'                                  /           /             /     /                    /     /
' DateTime  : 15/02/2018 16:46
' Author    : Simon
' Purpose   : Utility Functions
'---------------------------------------------------------------------------------------
'
Private Function PadAndQuoteJavascript(ByVal sJavascript As String, ByVal lPad As Long)
    PadAndQuoteJavascript = """" & Left$(sJavascript & String(lPad, " "), lPad) & """ "
End Function

Private Function VBALine(ByVal sJavascript As String, ByVal lLineIdx As Long, _
                                            ByVal lLineCount As Long) As String
    If lLineIdx = 0 Then
        VBALine = VBATopLine(sJavascript)
    ElseIf lLineIdx = lLineCount - 1 Then '* 0 based
        VBALine = VBABottomLine(sJavascript)
    Else
        VBALine = VBAMidLine(sJavascript)
    End If
End Function

Private Function VBABottomLine(ByVal sJavascript As String) As String
    VBABottomLine = vbTab & vbTab & vbTab & sJavascript
End Function

Private Function VBAMidLine(ByVal sJavascript As String) As String
    VBAMidLine = vbTab & vbTab & vbTab & sJavascript & " & _"
End Function

Private Function VBATopLine(ByVal sJavascript As String) As String
    VBATopLine = vbTab & "sProg = " & sJavascript & " & _"
End Function

Private Function JScriptFileFullPath() As String
    JScriptFileFullPath = fso.BuildPath(Environ$("tmp"), mcsJScriptFile)
End Function

Private Function ReadFilesIntoArray(ByVal sFilePath As String, ByRef plLineCount As Long)
    Dim txtIn As Scripting.TextStream
    Set txtIn = fso.OpenTextFile(sFilePath, ForReading, False, TristateUseDefault)
    
    Dim dicLines As Scripting.Dictionary
    Set dicLines = New Scripting.Dictionary
    
    While Not txtIn.AtEndOfStream
        
        dicLines.Add dicLines.Count, txtIn.ReadLine
        DoEvents
    Wend
    txtIn.Close
    Set txtIn = Nothing
    
    plLineCount = dicLines.Count
    
    ReadFilesIntoArray = dicLines.Items
End Function

VBA - Lambda Expressions - C# feature implemented with JScript

Summary: Use JScript in ScriptControl to replicate the C# feature of lambda expressions leveraging the FunctionDelegate pattern found previously here on this blog.

So in a previous post I showed how we can implement a FunctionDelegate to abstract away Application.Run and CallByName. The pattern is a useful one and we can add a third and fourth implementation. The third implementation is a Javascript function delegate and the fourth is a lambda expression based on Javascript.

The JavaScript Function Delegate

So we needed to update the factory class FnFactory (and that is given below) to create accept the source of a Javascript function as a parameter. We create an instance of the ScriptControl for the purposes of compilation only, we can harvest the name of the javascript function from the ScriptControl's own parsing of the function which is useful for when we want to call Run.

At execution time we created another instance of the ScriptControl, add the source and call the Run method. This is the simplest pattern. We could have been cleverer and shared ScriptControl instances. We could also feed in some global objects such as Application, ActiveWorkbook and ActiveSheet the existence of which VBA code can rely upon. For the time being we'll keep it simple.

If your Javascript has a compilation error you will get an error message of the pattern...

#Failed to create javascript function delegate because compilation failed with code (1004) and message 'Expected ';''

If you blink and you missed it then you can always call FnFactory.LastError which caches the last error.

Test examples are given in the test module (given module) here is a snippet. They demonstrate that you need to write in javascript (and not VBA!). So comparisons in Javascript use triple equals.

Private Sub TestFNJavascript0()

    Dim oFnDelegate As FunctionDelegate
    Set oFnDelegate = FnFactory.FnJavascript("function foo(bar) { return bar===1; }")

    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; }")
    
    Debug.Assert oFnDelegate2.Run(5) = 0 'root
    Debug.Assert oFnDelegate2.Run(-1) = 0 'root

    Debug.Assert oFnDelegate2.Run(1) = -8

End Sub

The Lambda Function Delegate

So the Lambda Function Delegate is based on the JavaScript Function, we simply look for the arrow operator => and see that as the dividing line between arguments to be passed (found on the left of the arrow) and implementation code (found to the right of the arrow). To convert to a javascript function is easy, we make up a function name using a random number, we place brackets around the arguments, we scrap the arrow and wrap the implementation code in curly brackets; finally, we add a return keyword to the final statement.

This means we can write lambda expression of the following form which respectively (i) test for equality to one, (2) adds two number...

    bar => bar===1
    x,y => x+y

We can even handle multi-statements and split on semi-colons (so please do not pass semi-colons inside strings or the code will break). So both the following do some Fibonacci logic, the first expression is hard coded to find the 6th Fibonacci term (given first two terms), the second expression calculates the n'th Fibonacci term.

    a,b =>  c=a+b; d=c+b; e=c+d; d+e 
    n => var fib = [0, 1]; for(var i=fib.length; i<=n; i++) {  fib.push( fib[i-2] + fib[i-1]);} ; fib[n]

So just to be clear the above expressions get compiled to the following javascript functions under the hood

function f96195316(bar) { return bar===1;}
function f87144583(x,y) { return x+y;}
function f56236861(a,b) { c=a+b; d=c+b; e=c+d; return  d+e ;}
function f36401868(n)   { var fib = [0, 1]; for(var i=fib.length; i<=n; i++) {  fib.push( fib[i-2] + fib[i-1]);} ; return  fib[n];}

And so here is the code, two classes and a standard module. Requires a Tools->Reference to Microsoft Script Control 1.0

The FnFactory class (global instancing)

Option Explicit

'* Tools References
'*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx


'---------------------------------------------------------------------------------------
' 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
' 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

'---------------------------------------------------------------------------------------
' 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   :
'---------------------------------------------------------------------------------------
' Arguments :
'    [in] sJavaScriptFunction    : the JavaScript function source
'    [in] bReturnTypeIsObject    : whether or not we need to say 'Set foo=Run(...' for returning an object
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJavascript(ByVal sJavaScriptFunction As String, _
                            Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate
    
    Dim oNewFD As FunctionDelegate
    Set oNewFD = New FunctionDelegate
    
    oNewFD.JavaScriptFunction = sJavaScriptFunction
    
    '* Tools References
    '*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
    Dim oSCForCompilationOnly As MSScriptControl.ScriptControl
    Set oSCForCompilationOnly = New MSScriptControl.ScriptControl
    oSCForCompilationOnly.Language = "JScript"
    
    Dim lSavedErrNum  As Long
    Dim sSavedErrDesc As String
    On Error Resume Next
    oSCForCompilationOnly.AddCode sJavaScriptFunction
    lSavedErrNum = Err.Number
    sSavedErrDesc = Err.Description
    On Error GoTo 0
    
    If lSavedErrNum <> 0 Then
    
        Dim sMsg As String
        msLastError = "#Failed to create javascript function delegate because compilation failed " & _
                    "with code (" & lSavedErrNum & ") and message '" & sSavedErrDesc & "'"
        Err.Raise vbObjectError, , msLastError
    Else
        '* so it compiled and not we can tease out details
        Dim oNewestProc As MSScriptControl.Procedure
        Set oNewestProc = oSCForCompilationOnly.Procedures.Item(oSCForCompilationOnly.Procedures.Count)
            
        oNewFD.HasReturnValue = oNewestProc.HasReturnValue
        oNewFD.JavaScriptName = oNewestProc.Name
        oNewFD.NumArgs = oNewestProc.NumArgs
        
        oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
        'Stop
        
        
    End If
    
    Set FnJavascript = oNewFD

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] sJavaScriptFunction    : the Lambda expression (uses JavaScript syntax underlying)
'    [in] bReturnTypeIsObject    : whether or not we need to say 'Set foo=Run(...' for returning an object
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJsLamda(ByVal sJsLamda As String, Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate

    If Len(sJsLamda) = 0 Then Err.Raise vbObjectError, "", "#Error null sJsLamda!"
    
    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, "=>")
    
    
    
    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 sDummyFunction As String
        sDummyFunction = "function f" & CLng((Rnd(1)) * 10 ^ 8) & "(" & Trim(vSplit(0)) & ") { 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, ";")
    
        sDummyFunction = "function f" & CLng((Rnd(1)) * 10 ^ 8) & "(" & Trim(vSplit(0)) & ") { " & Trim(sRejoined) & "}"
    
    End If
    
    Set FnJsLamda = FnJavascript(sDummyFunction, bReturnTypeIsObject)


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
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnAppRun(ByVal sMacro As String, Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate
    
    
    Dim oNewFD As FunctionDelegate
    Set oNewFD = New FunctionDelegate
    
    oNewFD.IsAppRun = True
    oNewFD.AppRunMacro = sMacro
    oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
    '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
'    [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 bReturnTypeIsObject As Boolean) As FunctionDelegate
    
    
    Dim oNewFD As FunctionDelegate
    Set oNewFD = New FunctionDelegate
    
    oNewFD.IsAppRun = False
    Set oNewFD.CallByNameTarget = oCallByNameTarget
    oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
    oNewFD.CallByNameType = eCallByNameType
    
    oNewFD.AppRunMacro = sMacro
    'oNewFD.mvArgs = vargs
    
    Set FnCallByName = oNewFD

End Function

The FunctionDelegate class

Option Explicit

'* Tools References
'*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx

'---------------------------------------------------------------------------------------
' 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

'* Added 14th Feb 2018
Private msJavaScriptFunction As String
Private msJavaScriptName As String
Private mbHasReturnValue As Boolean
Private mlNumArgs As Long

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
    
    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:\Windows\SysWOW64\msscript.ocx
        Dim oSCForExecution As MSScriptControl.ScriptControl
        Set oSCForExecution = New MSScriptControl.ScriptControl
        oSCForExecution.Language = "JScript"
        
        Dim lSavedErrNum  As Long
        Dim sSavedErrDesc As String
        oSCForExecution.AddCode Me.JavaScriptFunction
        
        If lArgCount = 0 Then
            
            If mbReturnTypeIsObject Then
                Set Run = oSCForExecution.Run(Me.JavaScriptName, msAppRunMacro)
            Else
                Run = oSCForExecution.Run(Me.JavaScriptName, msAppRunMacro)
            End If
        
        ElseIf lArgCount = 1 Then
            
            If mbReturnTypeIsObject Then
                Set Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0))
            Else
                Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0))
            End If
        
        ElseIf lArgCount = 2 Then
            
            If mbReturnTypeIsObject Then
                Set Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0), vargs(1))
            Else
                Run = oSCForExecution.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

End Function

The tstTestFnJavascript standard module

Option Explicit
Option Private Module

Private Sub TestAllFNJavascript()
    TestFNJavascript0
    TestFnJsLamda
End Sub


Private Sub TestFNJavascript0()

    Dim oFnDelegate As FunctionDelegate
    Set oFnDelegate = FnFactory.FnJavascript("function foo(bar) { return bar===1; }")
    

    
    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; }")
    
    Debug.Assert oFnDelegate2.Run(5) = 0 'root
    Debug.Assert oFnDelegate2.Run(-1) = 0 'root

    Debug.Assert oFnDelegate2.Run(1) = -8

End Sub

Private Sub TestFnJsLamda()


    'Set oFnDelegate = FnFactory.FnJsLamda("bar => bar===1")
    
    Dim fnLamda As FunctionDelegate
    Set fnLamda = FnFactory.FnJsLamda("bar => bar===1")
    
    Debug.Print fnLamda.JavaScriptFunction
    
    Debug.Assert fnLamda.Run(0) = False
    Debug.Assert fnLamda.Run(1) = True
    
    
    Dim fnLamda2 As FunctionDelegate
    Set fnLamda2 = FnFactory.FnJsLamda("x,y => x+y")
    
    Debug.Print fnLamda2.JavaScriptFunction
    
    Debug.Assert fnLamda2.Run(2, 2) = 4
    Debug.Assert fnLamda2.Run(3, -1) = 2
    
    Dim fnLamdaMultiStatement As FunctionDelegate
    Set fnLamdaMultiStatement = FnFactory.FnJsLamda("a,b => var c=a+b;var d=c+b;var e=c+d; d+e ")
    
    Debug.Assert fnLamdaMultiStatement.Run(1, 1) = 8
    
    Set fnLamdaMultiStatement = FnFactory.FnJsLamda("a,b =>  c=a+b; d=c+b; e=c+d; d+e ")
    Debug.Print fnLamdaMultiStatement.JavaScriptFunction
    Debug.Assert fnLamdaMultiStatement.Run(1, 1) = 8
    
    'https://stackoverflow.com/questions/7944239/generating-fibonacci-sequence
    Dim sFib As String
    sFib = "n => var fib = [0, 1]; for(var i=fib.length; i<=n; i++) {  fib.push( fib[i-2] + fib[i-1]);} ; fib[n]"
    
    Dim fnFibonacci As FunctionDelegate
    Set fnFibonacci = FnFactory.FnJsLamda(sFib)
    Debug.Print fnFibonacci.JavaScriptFunction
    Debug.Assert fnFibonacci.Run(0) = 0
    Debug.Assert fnFibonacci.Run(1) = 1
    Debug.Assert fnFibonacci.Run(2) = 1
    Debug.Assert fnFibonacci.Run(3) = 2
    Debug.Assert fnFibonacci.Run(4) = 3
    Debug.Assert fnFibonacci.Run(5) = 5
    Debug.Assert fnFibonacci.Run(6) = 8
    

End Sub

VBA - IE - CreateEvent and DispatchEvent to synthesise an event

Summary: Inject Javascript to create and dispatch an event in Internet Explorer using CreateEvent and DispatchEvent

IE is different from other browsers and so there sometimes is an 'IE way of doing things'. This is true when trying to synthesise an event, typically during web-scraping. To synthesise an event in IE requires calling CreateEvent and then calling DispatchEvent. The calling syntax is not obvious so here I lay down an example for reference.

The code injects javascript using the execScript method. Also a console stack trace feature is given.

TIP: It turns out that when webscraping and manipulating HTML input boxes etc. it is better for the manipulated HTML element to take the focus; this can obviate the need to synthesise events.

The VBA code

Option Explicit

'* Tools - References
'*      MSHTML      Microsoft HTML Object Library                   C:\Windows\SysWOW64\mshtml.tlb
'*      SHDocVw     Microsoft Internet Controls                     C:\Windows\SysWOW64\ieframe.dll
'*      Shell32     Microsoft Shell Controls And Automation         C:\Windows\SysWOW64\shell32.dll

Private Function ReacquireInternetExplorer(ByVal sMatch As String) As Object
    Dim oShell As Shell32.Shell: Set oShell = New Shell32.Shell
    Dim wins As Object: Set wins = oShell.Windows
    Dim winLoop As Variant
    For Each winLoop In oShell.Windows
        If "C:\Program Files (x86)\Internet Explorer\IEXPLORE.EXE" = winLoop.FullName Then

            Dim sFile2 As String
            sFile2 = "file:///" & VBA.Replace(sMatch, "\", "/")
            If StrComp(sFile2, winLoop.LocationURL, vbTextCompare) = 0 Then
                Set ReacquireInternetExplorer = winLoop.Application
                GoTo SingleExit
            End If
        End If
    Next
SingleExit:
End Function

Sub test()

    Dim objIE As InternetExplorer
    Set objIE = New InternetExplorer
    Dim oHtml As HTMLDocument
    Dim HTMLtags As IHTMLElementCollection


    Dim sUrl As String
    sUrl = "C:\Users\Simon\source\repos\WebApplication2\WebApplication2\HtmlPage1.html"

    objIE.Visible = True
    objIE.Navigate sUrl

    If StrComp(Left(sUrl, 3), "C:\") = 0 Then
        Stop '* give chance to clear the activex warning box for the local file
        Set objIE = ReacquireInternetExplorer(sUrl)
    End If
    Do Until objIE.readyState = READYSTATE_COMPLETE: DoEvents: Loop
    Set oHtml = objIE.Document

    Do
        '* wait for the input box to be ready
        Set HTMLtags = oHtml.getElementsByClassName("OrderForm_input-box_XkGmi")
        DoEvents
    Loop While HTMLtags.Length = 0

    Dim objWindow As MSHTML.HTMLWindow2
    Set objWindow = objIE.Document.parentWindow


    
    Const csJavaScriptConsoleTrace As String = "var divTotal = document.querySelector('div.OrderForm_total_6EL8d'); " & _
                                                 "divTotal.onchange = function() { console.trace(); }"
    
    objWindow.execScript csJavaScriptConsoleTrace


    '* next line sets the input box and raises an event, works on local file but not on GDAX
    
    Const csJavaScriptSynthesiseEvents As String = _
                "var inputBox = document.querySelector('div.OrderForm_input-box_XkGmi input'); " & _
                "inputBox.value = 100; " & _
                "if (document.createEvent) { " & _
                "  var event2 = document.createEvent('HTMLEvents'); " & _
                "  event2.initEvent('input', false, false); " & _
                "  event2.eventName = 'input'; inputBox.dispatchEvent(event2); " & _
                "}"
    objWindow.execScript csJavaScriptSynthesiseEvents


    'get the Total(LTC) to cross check
    Do
        '* wait for the order total div to be ready
        Set HTMLtags = oHtml.getElementsByClassName("OrderForm_total_6EL8d")
        DoEvents
    Loop While HTMLtags.Length = 0

    Dim divTotal As HTMLDivElement
    Set divTotal = oHtml.querySelector("div.OrderForm_total_6EL8d")
    Debug.Print divTotal.innerText & " Total(LTC)"

    Stop

End Sub

The HTML page

    <!DOCTYPE html>
    <html>
    <head>
        <meta charset="utf-8" />
        <title></title>
    </head>
    <body>
        <input id="Button1" type="button" value="Programmatically write textbox value" onclick="TestAlert()" />

        <form class="OrderForm_form_25r0u">
            <ul class="OrderForm_trade-type_2QyK4">
                <li class="OrderForm_trade-type-tab_uWGMp OrderForm_active_Di-9p">MARKET</li>
                <li class="OrderForm_trade-type-tab_uWGMp">LIMIT</li>
                <li class="OrderForm_trade-type-tab_uWGMp">STOP</li>
            </ul>
            <ul class="OrderForm_toggle_120Ka">
                <li class="OrderForm_toggle-tab_bZZnC OrderForm_buy_38n5g OrderForm_active_Di-9p">BUY</li>
                <li class="OrderForm_toggle-tab_bZZnC OrderForm_sell_3vYRQ">SELL</li>
            </ul>
            <div class="market-order">
                <div class="OrderForm_section_2Znad">
                    <div class="OrderForm_section-header_fwFDB">Amount</div>
                    <div class="OrderForm_input-box_XkGmi">
                        <input type="number" step="0.01" min="0" name="amount" 
           placeholder="0.00" value="" autocomplete="off" oninput="myOnInputHandler()">
                        <span>EUR</span>
                    </div>
                </div>
            </div>
            <div class="OrderForm_order-total_3Mkdz">
                <div>
                    <b>Total</b>
                    <span>(LTC)</span>
                    <b>≈</b>
                </div>
                <div class="OrderForm_total_6EL8d" >0.00000000</div>
            </div>
        </form>

        <script language="javascript">
            function myOnInputHandler() {
                print_call_stack();
                alert('you input something');
            }

            function print_call_stack() { console.trace(); }

            function print_call_stack2() {
                var stack = new Error().stack;
                console.log("PRINTING CALL STACK");
                console.log(stack);
            }


            function TestAlert() { setInputBox(document); }

            function setInputBox() {
                try {
                    var inputBox = document.querySelector('div.OrderForm_input-box_XkGmi input'); 
     inputBox.value = 100; 
     if (document.createEvent) { 
      var event2 = document.createEvent("HTMLEvents"); 
      event2.initEvent("input", true, true); 
      event2.eventName = "input"; inputBox.dispatchEvent(event2); 
     }

                    return ({ success: true });
                }
                catch (ex) {
                    return ({ exception: ex, myMsg: '#error in setInputBox!' });
                }
            }

        </script>
    </body>
    </html>

VBA - Visual Studio (2017) Interop - Automated copy source of XHTML file

Summary: This VBA will copy a file into a Visual Studio Project Item, in this case an XHTML to check for XHTML5 compliance but could be used for copying other source to other project items.

So, I had cause to upgrade some HTML4 to XHTML5, the best validator would be Visual Studio (I'm using 2017), if one creates a C# WebApplication and adds a WebForm then the default HTML schema is XHTML5 with closed tags and no upper case element tagnames or attributes as well as other structural syntax changes. I needed to eyeball a whole directory of HTML files with this validator so I chose to write some code to automate.

The code first gets hold of the solution from the Running Object Table, in VBA.GetObject will do this. Then we find the project, the project item and then the text. The copy across is based on EditPoints. Warning, the Microsoft web sites for this has long running scripts which is a pain.

The test standard module

Option Explicit
Option Private Module
Private Sub TestReplaceWebPageText()
    
    Dim oVisualStudioSolutionHandler As VisualStudioSolutionHandler
    Set oVisualStudioSolutionHandler = New VisualStudioSolutionHandler
    
    Call oVisualStudioSolutionHandler.ReplaceWebPageText( _
                "C:\Users\Simon\source\repos\WebApplication1\WebApplication1.sln", _
                "WebApplication1", "WebForm1.aspx", _
                "C:\Users\Simon\AppData\Local\Temp\foobar.xhtml")
End Sub

VisualStudioSolutionHandler class module

Option Explicit

'* Tools References
'*
'*   EnvDTE           
'*     Microsoft Development Environment 8.0 (Version 7.0 Object Model)    
'*     C:\Program Files (x86)\Common Files\Microsoft Shared\MSEnv\dte80a.olb
'*
'*   Scripting
'*     Microsoft Scripting Runtime                                         
'*     C:\Windows\SysWOW64\scrrun.dll


Private Function SafeTypeNameGetObject(ByVal sRunningObject As String) As String
    On Error Resume Next
    SafeTypeNameGetObject = TypeName(GetObject(sRunningObject))
End Function

Public Sub ReplaceWebPageText(ByVal sSolutionPath As String, _
                                ByVal sProjectName As String, _
                                ByVal sWebFormName As String, _
                                ByVal sXhtmlFileName As String)

    Const csWebFormHeader As String = _
        "<%@ Page Language=""C#"" AutoEventWireup=""true"" CodeBehind=""WebForm1.aspx.cs"" Inherits=""WebApplication1.WebForm1"" %>"

    If Len(sSolutionPath) = 0 Then Err.Raise vbObjectError, , "#Null sSolutionName!"
    If Len(sProjectName) = 0 Then Err.Raise vbObjectError, , "#Null sProjectName!"
    If Len(sWebFormName) = 0 Then Err.Raise vbObjectError, , "#Null sWebFormName!"
    If Len(sXhtmlFileName) = 0 Then Err.Raise vbObjectError, , "#Null sXhtmlFileName!"

    If StrComp(Right$(sXhtmlFileName, 6), ".xhtml", vbTextCompare) <> 0 Then _
                    Err.Raise vbObjectError, , "#sXhtmlFileName  '" & sXhtmlFileName & "' should end with '.xhtml'!"

    Static fso As New Scripting.FileSystemObject
    If Not fso.FileExists(sXhtmlFileName) Then Err.Raise vbObjectError, , "#sXhtmlFileName '" & sXhtmlFileName & "' does not exist!"
    If Not fso.FileExists(sSolutionPath) Then Err.Raise vbObjectError, , "#sSolutionPath '" & sSolutionPath & "' does not exist!"
    
    If VBA.StrComp(Right$(sSolutionPath, 4), ".sln", vbTextCompare) <> 0 Then _
                    Err.Raise vbObjectError, , "#sSolutionPath '" & sSolutionPath & "' should end with '.sln'!"
    
    Dim sResolvedType As String
    sResolvedType = SafeTypeNameGetObject(sSolutionPath)
    If VBA.StrComp(sResolvedType, "Solution", vbTextCompare) <> 0 Then Err.Raise vbObjectError, , _
            "#Expectin sSolutionPath '" & sSolutionPath & "' to resolve to a solution instead resolved to '" & sResolvedType & "'!"
    
        
    
    Dim sReplacementText As String
    sReplacementText = csWebFormHeader & vbNewLine & vbNewLine
    
    Dim txtIn As Scripting.TextStream
    Set txtIn = fso.OpenTextFile(sXhtmlFileName, ForReading, False, TristateUseDefault)
    
    While Not txtIn.AtEndOfStream
        DoEvents
        sReplacementText = sReplacementText & vbNewLine & txtIn.ReadLine
    Wend
    
    
    Dim sol As EnvDTE.Solution
    Set sol = GetObject(sSolutionPath)

    Dim webProj As EnvDTE.Project
    Set webProj = GetVSProject(sol, sProjectName)

    Dim webForm1 As EnvDTE.ProjectItem
    Set webForm1 = webProj.ProjectItems.Item(sWebFormName)
    
    
    
    Dim webForm1Doc As EnvDTE.Document
    Set webForm1Doc = webForm1.Document

    Dim webForm1TextDoc As EnvDTE.TextDocument
    Set webForm1TextDoc = webForm1Doc.Selection.Parent

    'https://docs.microsoft.com/en-us/dotnet/api/envdte.textdocument.createeditpoint?redirectedfrom=MSDN&view=visualstudiosdk-2017
    Debug.Assert webForm1TextDoc Is webForm1Doc.Object("TextDocument")

    Dim objStartPt As EnvDTE.EditPoint
    Set objStartPt = webForm1TextDoc.CreateEditPoint(webForm1TextDoc.StartPoint)

    Dim objEndPt As EnvDTE.EditPoint
    Set objEndPt = webForm1TextDoc.CreateEditPoint(webForm1TextDoc.EndPoint)


    'https://docs.microsoft.com/en-us/dotnet/api/envdte.editpoint.replacetext?view=visualstudiosdk-2017
    objStartPt.ReplaceText objEndPt, sReplacementText, 0
    
    webForm1.Save

    'Stop
SingleExit:
End Sub


Public Function GetVSProject(ByVal sol As EnvDTE.Solution, ByVal sProjectName As String) As EnvDTE.Project

    If Not sol Is Nothing Then
    
        Dim lProjectLoop As Long
        For lProjectLoop = 1 To sol.Projects.Count
            
            Dim prjLoop As EnvDTE.Project
            Set prjLoop = sol.Projects.Item(lProjectLoop)
            
            If VBA.StrComp(prjLoop.Name, sProjectName, vbTextCompare) = 0 Then
                Set GetVSProject = prjLoop
                GoTo SingleExit
            
            End If
        
        Next lProjectLoop
    
    End If
SingleExit:

End Function