VBA - MSForms - retrieving a listbox's selected items

Worth laying down some sample code as to how to fill a form's listbox and how to query for the selected items...

We populate a Listbox with a two-dimensional array , like that lifted from a worksheet with lbx.List = vValues. I prefer to communicate the selected items with a Dictionary, because I get a second piece of info, in the code below the row number of the selected item. Then to list the items just use the Dictionary's Items() method. Absolutely no need to redimension arrays, use the Dictionary to cope.

P.S. In code below I have a function CompiledHelpFiles() exported off the shtCompiledHelpFiles sheet which gives a 2d values array. I do this to stop direct access to the worksheet which I think is not good separation of concerns.

P.P.S. Don't forget to set the MultiSelect property on the Listbox to frmMultiSelectExtended.

Private Sub PopulateCompiledHelpFilesListBox()
    Dim vValues As Variant
    vValues = shtCompiledHelpFiles.CompiledHelpFiles
    
    lbxCompiledHelpFiles.List = vValues

End Sub


Private Sub cmdDecompile_Click()

    Dim dicSelected As Scripting.Dictionary
    Set dicSelected = GetListBoxSelectedItems(Me.lbxCompiledHelpFiles)

    Dim vFiles As Variant
    vFiles = dicSelected.Items
    
    

    Dim vFileLoop As Variant
    For Each vFileLoop In vFiles
        '* do work on each file
    
    Next vFileLoop

    

End Sub


Private Function GetListBoxSelectedItems(ByVal lbxBox As MSForms.ListBox) As Scripting.Dictionary
    'returns a dictionary with selected and row number
    Dim dicSelected As Scripting.Dictionary
    Set dicSelected = New Scripting.Dictionary
    
    Dim lRow As Long
    For lRow = 0 To lbxBox.ListCount - 1
        If lbxBox.Selected(lRow) Then
            dicSelected.Add lRow, lbxBox.List(lRow)
        End If
    Next

    Set GetListBoxSelectedItems = dicSelected

End Function

VBA - C# - Excel as a Web Server with REST interface

Summary: Use a C# addin to give the multi-threading necessary to turn Excel into a web server and build logic in Excel VBA to handle REST requests.

So I am quite proud of this piece of work, I am interested in Excel VBA inter-operating with the Internet as a client and so using MSXML2.XMLHTTP60 for XHR and Internet Explorer for web-scraping. But this piece of work turns the tables, and Excel.exe becomes a web server. It uses a C# addin which serves static files and also forwards REST requests to Excel VBA.

Because this is a larger than normal piece of work I thought I'd make videos instead of typing out a very long script. The videos can be found here on Youtube. But here on this page one can find the source files.

Home.html

<!DOCTYPE html>

<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
<head>
    <script src="https://ajax.googleapis.com/ajax/libs/angularjs/1.6.9/angular.min.js"></script>
    <style>

        .noselect {
            -webkit-touch-callout: none; 
            -webkit-user-select: none; 
            -moz-user-select: none; 
            -ms-user-select: none; 
            user-select: none; 
        }


        .flex-container {
            display: flex;
            flex-direction: column;
            background-color: goldenrod;
            width: 320px;
        }

            .flex-container > div {
                background-color: darkgoldenrod;
                width: 96%;
                margin: 2%;
            }

                .flex-container > div > div {
                    width: 96%;
                    margin: 2%;
                }


    </style>
    <title>Welcome to the Foo Bar!</title>
</head>
<body class="noselect" style="cursor: default">
    <div class="flex-container" ng-app="myApp" ng-controller="myCtrl">
        <!--* ng-init="beers=[{"Brand":"Bud","Country":"US"},{"Brand":"Coors","Country":"canada"}]" */-->
        <div >
            <div>
                <h2>Welcome to the Foo Bar!</h2>
            </div>
        </div>
        <div>
            <div>
                <div style="width:100%">Today's top beer is: <span ng-bind="todaysTopBeers"></span><br /></div>
                <div>news:<span ng-bind="status"></span><br /></div>
                <div><button ng-click="takeDelivery()">Take Delivery</button></div>
            </div>
        </div>
        <div>
            <table class="beerTable" style="background-color:darkgoldenrod; width:300px">
                <tr>
                    <th>Brand</th>
                    <th>Country</th>
                </tr>
                <thead></thead>
                <tbody>
                    <tr ng-repeat="beer in beers">
                        <td>{{ beer.Brand }}</td>
                        <td>{{ beer.Country }}</td>
                        <td ng-click="deleteBeer(beer.Brand)" onmouseover="this.style.color='red';"
                            onmouseout="this.style.color='black';">
                            ×
                        </td>
                    </tr>
                </tbody>
            </table>
        </div>
        <div>
            <div>
                <span>Add another beer</span>
                <table>
                    <tr><td style="width:80px">Brand:</td><td><input type="text" ng-model="addBeer.Brand"></td></tr>
                    <tr><td style="width:80px">Country:</td><td><input type="text" ng-model="addBeer.Country"></td></tr>
                </table>
                <br>
                <button ng-click="postBeer()">Add</button>
            </div>
        </div>
    </div>

    <script>
        var app = angular.module('myApp', []);
        app.controller('myCtrl', function ($scope, $http) {

            $scope.takeDelivery = function () {
                $http.post("/theFooBar/deliveries/")
                    .then(function successCallback(response) {

                        $scope.status = "a delivery has been made";
                        $scope.getBeers();

                    }, function errorCallback(data) {
                        $scope.status = data;
                        console.log("error");
                    });
            };

            $scope.postBeer = function () {
                var data = $scope.addBeer;
                $http.post("/theFooBar/beers/", data)
                    .then(function successCallback(response) {

                        $scope.status = "updated beer";
                        $scope.getBeers();

                    }, function errorCallback(data) {
                        $scope.status = data;
                        console.log("error");
                    });
            };

            $scope.putBeer = function () {
                var data = $scope.addBeer;
                $http.put("/theFooBar/beers/", data)
                    .then(function successCallback(response) {

                        $scope.status = "updated beer";

                    }, function errorCallback(data) {
                        $scope.status = data;
                        console.log("error");
                    });
            };

            $scope.getBeers = function () {
                $http.get("/theFooBar/beers/")
                    .then(function successCallback(response) {

                        
                        $scope.beers = response.data;
                        $scope.todaysTopBeers = $scope.beers[0].Brand + ' ' + $scope.beers[0].Country + '!';

                    }, function errorCallback(data) {
                        $scope.status = data;
                        console.log("error");
                    });
            }
            $scope.getBeers(); // run this first time

            $scope.deleteBeer = function (beerName) {
                $http.delete("/theFooBar/beers/" + beerName)
                    .then(function successCallback(response) {

                        $scope.status = beerName + " is finished";

                        var lookupBeer = $scope.lookupBeer($scope.beers, beerName);
                        if (lookupBeer !== -1) { $scope.beers.splice(lookupBeer, 1); }
                        if ($scope.beers.length > 0) {
                            $scope.todaysTopBeers = $scope.beers[0].Brand + ' ' + $scope.beers[0].Country + '!';
                        } else {
                            $scope.todaysTopBeers = "";
                        }

                    }, function errorCallback(data) {
                        $scope.status = data;
                        console.log("error");
                    });
            }

            $scope.lookupBeer =
                function lookupBeer(beers, beerBrand) {
                    for (var i = 0; i < beers.length; i++) {
                        var beerLoop = beers[i];
                        if (beerLoop.Brand === beerBrand) {
                            return i;
                        }
                    }
                    return -1;
                }
        });
    </script>
</body>
</html>

VBA standard module modHttpRequest.bas

Option Explicit

'* Tools->References
'MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
'Scripting          Microsoft Scripting Runtime     C:\Windows\SysWOW64\scrrun.dll
'MSXML2             Microsoft XML, v6.0             C:\Windows\SysWOW64\msxml6.dll

Private moBeers As Object '*JScriptTypeInfo


'---------------------------------------------------------------------------------------
' Procedure : HttpRequest
' DateTime  : 02/03/2018 08:39
' Author    : Simon
' Purpose   : This is called by the ExcelWebAddin, it features all that you'd expect
'             for servicing a web request:
'             * the url (parsed into components)
'             * the query string (parsed into key value pairs)
'             * any posted data
'             * the request headers and cookies
'             * the response headers and cookies
'
'             The query string, request headers and request cookies dictionaries are purely
'             informational only, adding entries to any of these does nothing.
'
'             The response headers and response cookies dictionaries are to be written to
'             but there is no need to create a new Dictionary, simply add entries to
'             those that have been passed
'
'---------------------------------------------------------------------------------------
' Arguments :
'   dicUrl[in]                  : a dictionary of properties relating to the url and its components
'   sHttpMethod[in]             : the HTTP method, GET, PUT, POST, DELETE etc.
'   dicQueryString[in]          : a dictionary containing the query string as key-value pairs
'   bHasBody[in]                : a boolean to signal presence of posted data
'   abBody[in]                  : a byte array containing any posted data
'   dicRequestHeaders[in]       : a dictionary containing request headers
'   dicRequestCookies[in]       : a dictionary containing request cookies
'   dicResponseHeaders[in,out]  : a dictionary to be written to in order to set response headers
'   dicResponseCookies[in,out]  : a dictionary to be written to in order to set response cookies
'   dicStatusCode[in,out]       : a dictionary to be written to in order to set response status code
'   retval[out,retval]          : a string, the HTML, XML, JSON or text that fulfils the request
'
Public Function HttpRequest(ByVal dicUrl As Dictionary, ByVal sHttpMethod As String, _
                    ByVal dicQueryString As Dictionary, _
                    ByVal bHasBody As Boolean, ByRef abBody() As Byte, _
                    ByVal dicRequestHeaders As Dictionary, ByVal dicRequestCookies As Dictionary, _
                    ByVal dicResponseHeaders As Dictionary, ByVal dicResponseCookies As Dictionary, _
                    ByVal dicStatusCode As Dictionary) As String
    
    Dim vUrlSegments As Variant
    vUrlSegments = dicUrl.Item("Segments").Items()
    
    If bHasBody Then
        Dim sBody As String
        sBody = StrConv(abBody, vbUnicode)
    End If
    
    '* next line can be commented out, it is here to demonstrate the richness of the request parameters
    DumpRequestInfo dicUrl, sHttpMethod, dicQueryString, dicRequestHeaders, dicRequestCookies


    '* next lines sets the return value, it contains the document that fulfiles the webrequest
    '* choose one

'    HttpRequest = "Hello world"  '* plain text
'    dicResponseHeaders.Add "Content-Type", "text/plain"
    
'    HttpRequest = "<html><body>Hello world</body></html>"  '* Html
'    dicResponseHeaders.Add "Content-Type", "text/html"

'    HttpRequest = "<xmlDoc><xmlEle>Hello world</xmlEle></xmlDoc>"  '* Xml
'    dicResponseHeaders.Add "Content-Type", "application/xml"
    
    If StrComp(Left$(dicUrl.Item("AbsolutePath"), Len("/theFooBar/beers/")), "/theFooBar/beers/", vbTextCompare) = 0 Then
        '* we're here for the beer :)
        
        '* response governed by https://tools.ietf.org/html/rfc7231#section-4.3
        
        Select Case sHttpMethod
        Case "GET":
        
            HttpRequest = ScriptControl.Run("JSON_stringify", moBeers)
            
            dicResponseHeaders.Add "Content-Type", "application/json"
            dicStatusCode.Add 200, 0
        Case "POST":
            Dim oNewBeer As Object
            Set oNewBeer = ScriptControl.Run("JSON_parse", sBody)
        
            Call ScriptControl.Run("addBeer", moBeers, oNewBeer)
            'Stop
            dicStatusCode.Add 201, 0
        
        Case "PUT":
        
            Dim oUpdateBeer As Object
            Set oUpdateBeer = ScriptControl.Run("JSON_parse", sBody)
    
            Call ScriptControl.Run("updateBeer", moBeers, oUpdateBeer)
        
            'Stop
            dicStatusCode.Add 200, 0
        Case "DELETE":

            Call ScriptControl.Run("deleteBeer", moBeers, CStr(vUrlSegments(3))) '* seems to need CStr()
            HttpRequest = vbNullString '* empty https://stackoverflow.com/questions/25970523/restful-what-should-a-delete-response-body-contain#25970628
            dicStatusCode.Add 204, 0
            'Stop
        End Select
    ElseIf StrComp(Left$(dicUrl.Item("AbsolutePath"), Len("/theFooBar/deliveries/")), "/theFooBar/deliveries/", vbTextCompare) = 0 Then
    
        Select Case sHttpMethod
        Case "GET": '* no implementation
        Case "POST":
            '* a delivery was made all beers back on the menu
            Set moBeers = ScriptControl.Run("JSON_parse", DefaultBeerTable)
            dicStatusCode.Add 200, 0
        
        Case "PUT": '* no implementation
        Case "DELETE": '* no implementation
        End Select
    
    
    Else
        dicStatusCode.Add 404, 0
    
    
    End If

    
    '* next lines illustrate setting response headers and response cookies
    'dicResponseCookies.Add "UserName", Environ$("username")
    'dicResponseHeaders.Add "Server", "ExcelVBA: " & ThisWorkbook.Name
    'dicResponseHeaders.Add "Foo", "Bar"
End Function


'---------------------------------------------------------------------------------------
' Procedure : ScriptControl
' DateTime  : 03/03/2018 16:28
' Author    : Simon
' Purpose   : This creates a ScriptControl for containing Javascript functions
'---------------------------------------------------------------------------------------
' Arguments :
'    [out,retval]   : the scriptcontrol Javascript container populated with essential functions
'
Private Function ScriptControl() As ScriptControl
    Static oScriptControl As ScriptControl
    If oScriptControl Is Nothing Then
        Set oScriptControl = New ScriptControl
        oScriptControl.Language = "JScript"
            
        oScriptControl.AddCode "function deleteValueByKey(obj,keyName) { delete obj[keyName]; } "
        oScriptControl.AddCode "function setValueByKey(obj,keyName, newValue) { obj[keyName]=newValue; } "
        oScriptControl.AddCode "function enumKeysToMsDict(jsonObj,msDict) { for (var i in jsonObj) { msDict.Add(i,0); }  } "
        oScriptControl.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        oScriptControl.AddCode "function JSON_stringify(value, replacer,spacer) { return JSON.stringify(value, replacer,spacer); } "
        oScriptControl.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "
        
        
        '* using a separate variable to populate first,
        '* which is not strictly necessary but I like the
        '* prettiness of the alignment/justification
        Dim sProg As String
                
        sProg = "function lookupBeer(beers, beerBrand) {" & _
                "   for (var i = 0; i < beers.length; i++) {" & _
                "        var beerLoop = beers[i];" & _
                "        if (beerLoop.Brand === beerBrand) {" & _
                "            return i;" & _
                "        }" & _
                "    }" & _
                "    return -1;" & _
                "}"
        oScriptControl.AddCode sProg
        
        sProg = "function deleteBeer(beers, beerName) { " & _
                "   var lookup = lookupBeer(beers, beerName);" & _
                "   if (lookup !== -1) { beers.splice(lookup, 1); }" & _
                "}"
        oScriptControl.AddCode sProg
        
        sProg = "function addBeer(beers, newBeer) { " & _
                "   var lookup = lookupBeer(beers, newBeer.Brand);" & _
                "   if (lookup === -1) { beers.push(newBeer); }" & _
                "}"
        oScriptControl.AddCode sProg
        
        sProg = "function updateBeer(beers, newBeer) { " & _
                "   var lookup = lookupBeer(beers, newBeer.Brand);" & _
                "   if (lookup !== -1) { beers[lookup]=newBeer; }" & _
                "}"
        oScriptControl.AddCode sProg
        
        Set moBeers = oScriptControl.Run("JSON_parse", DefaultBeerTable)
    End If
    Set ScriptControl = oScriptControl

End Function


'---------------------------------------------------------------------------------------
' Procedure : GetJavaScriptLibrary
' DateTime  : 03/03/2018 16:27
' Author    : Simon
' Purpose   :
'---------------------------------------------------------------------------------------
' Arguments :
'    sURL[in]     : the url of the javascript library to download
'    [out,retval] : the source code of the javascript library
'
Private Function GetJavaScriptLibrary(ByVal sURL As String) As String

    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.send
    GetJavaScriptLibrary = xHTTPRequest.responseText

End Function

'---------------------------------------------------------------------------------------
' Procedure : DefaultBeerTable
' DateTime  : 03/03/2018 16:26
' Author    : Simon
' Purpose   : we need to start out with some data so here is a JSON strings which is
'             an array of beers
'---------------------------------------------------------------------------------------
' Arguments :
'    [out,retval]   : a JSON string which contains default entries
'
Private Function DefaultBeerTable() As String
    DefaultBeerTable = "[{""Brand"": ""Budweiser"", ""Country"":""US""}, {""Brand"": ""Tsingtao"", ""Country"":""China""}," & _
                      "{""Brand"": ""Heineken"", ""Country"": ""Holland""}, {""Brand"": ""Brahma"", ""Country"":""Brazil""}]"
End Function

'---------------------------------------------------------------------------------------
' Procedure : DumpRequestInfo
' DateTime  : 02/03/2018 10:20
' Author    : Simon
' Purpose   : outputs to immediate window all the richness of the request parameters
'---------------------------------------------------------------------------------------
' Arguments :
'   dicUrl[in]                  : a dictionary of properties relating to the url and its components
'   sHttpMethod[in]             : the HTTP method, GET, PUT, POST, DELETE etc.
'   dicQueryString[in]          : a dictionary containing the query string as key-value pairs
'   dicRequestHeaders[in]       : a dictionary containing request headers
'   dicRequestCookies[in]       : a dictionary containing request cookies
'
Private Sub DumpRequestInfo(ByVal dicUrl As Dictionary, ByVal sHttpMethod As String, _
                    ByVal dicQueryString As Dictionary, _
                    ByVal dicRequestHeaders As Dictionary, ByVal dicRequestCookies As Dictionary)
    
    Debug.Print "****" & vbNewLine & "URL:" & vbNewLine & DictionaryToString(dicUrl) & vbNewLine
    'Debug.Print "****" & vbNewLine & Pad("HTTP:", 32) & sHttpMethod & vbNewLine
    'Debug.Print "****" & vbNewLine & "QUERYSTRING:" & vbNewLine & DictionaryToString(dicQueryString) & vbNewLine
    'Debug.Print "****" & vbNewLine & "REQUESTHEADERS:" & vbNewLine & DictionaryToString(dicRequestHeaders) & vbNewLine
    'Debug.Print "****" & vbNewLine & "REQUESTCOOKIES:" & vbNewLine & DictionaryToString(dicRequestCookies) & vbNewLine
    
    
End Sub

'---------------------------------------------------------------------------------------
' Procedure : DictionaryToString
' DateTime  : 02/03/2018 10:03
' Author    : Simon
' Purpose   : routine to help pretty print a dictionary's contents
'---------------------------------------------------------------------------------------
' Arguments :
'   dic[in]        : the dictionary whose contents we want to print
'   sDelimiter[in] : typically a new line
'   lPadKey[in]    : used to justifty/align
'   [out,retval]   : the string representation of the dictionary
'
Private Function DictionaryToString(ByVal dic As Scripting.Dictionary, _
                            Optional ByVal sDelimiter As String = vbNewLine, _
                            Optional ByVal lPadKey As Long = 32) As String
                            
    Dim vKeyLoop As Variant, sKVP As String, sRetVal As String
    For Each vKeyLoop In dic.Keys
        Dim sPaddedKey As String: sPaddedKey = vbNullString
        
        If Len(vKeyLoop) + 2 < lPadKey Then sPaddedKey = Pad(vKeyLoop & ": ", lPadKey) Else sPaddedKey = vKeyLoop & ": "
    
        If Not IsObject(dic.Item(vKeyLoop)) Then
            sKVP = sPaddedKey & dic.Item(vKeyLoop)
        Else
            sKVP = sPaddedKey & "{ " & DictionaryToString(dic.Item(vKeyLoop), " ; ", 0) & " }"
        End If
        If Len(sRetVal) > 0 Then sRetVal = sRetVal & sDelimiter
        sRetVal = sRetVal & sKVP
        
        sPaddedKey = vbNullString
    Next vKeyLoop
    
    DictionaryToString = sRetVal

End Function

'---------------------------------------------------------------------------------------
' Procedure : Pad
' DateTime  : 02/03/2018 10:19
' Author    : Simon
' Purpose   : pad a string, used to align/justify
'---------------------------------------------------------------------------------------
' Arguments :
'    s[in]        : The string to pad
'    lPad[in]     : the numbers of characters to pad
'    [out,retval] : returns a padded string
'
Private Function Pad(ByVal s As String, ByVal lPad As Long) As String
    Pad = Left(s & String(lPad, " "), lPad)
End Function

'---------------------------------------------------------------------------------------
' Procedure : TestHttpRequest
' DateTime  : 26/02/2018 15:42
' Author    : Simon
' Purpose   : Run this to ensure your macros are enabled whilst troubleshooting
'---------------------------------------------------------------------------------------
'
Public Sub TestHttpRequest()
    Dim abBody() As Byte
    Debug.Print Application.Run(ThisWorkbook.Name & "!HttpRequest", NewDictionary(), "GET", NewDictionary(), _
                            False, abBody, _
                            NewDictionary(), NewDictionary(), _
                            NewDictionary(), NewDictionary())
End Sub

'---------------------------------------------------------------------------------------
' Procedure : NewDictionary
' DateTime  : 02/03/2018 09:23
' Author    : Simon
' Purpose   : allows anonymous dictionaries (no need to declare variable) to be created
'---------------------------------------------------------------------------------------
' Arguments :
' [out,retval]  : a newly created Scripting.Dictionary object
'
Private Function NewDictionary() As Dictionary
    Set NewDictionary = New Scripting.Dictionary
End Function

C# Addin source

using System;
using Excel = Microsoft.Office.Interop.Excel;
using System.Collections.Generic;
using System.Net;
using System.Text;
using System.Threading;
using System.Runtime.InteropServices;

using Scripting; // Added COM reference to COM library 'Microsoft Scripting Runtime'
using System.IO;

namespace ExcelWebServerAddIn
{
    public class WebServer
    {
        /*
         * With effusive thanks and great praise to David's Blog
         * https://codehosting.net/blog/BlogEngine/post/Simple-C-Web-Server
         * a big win!
         */
        private readonly HttpListener _listener = new HttpListener();
        private readonly Func<HttpListenerRequest, Scripting.Dictionary, Scripting.Dictionary, Scripting.Dictionary, string> _responderMethod;

        /// <summary>
        /// Mime Type conversion table (with thanks to Caio Proiete https://gist.github.com/caioproiete/0a22dd020045a0fee239 )
        /// TODO replace with more "official" https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types
        /// </summary>
        private static IDictionary<string, string> _mimeTypeMappings =
            new Dictionary<string, string>(StringComparer.InvariantCultureIgnoreCase)
            {
                #region extension to MIME type list
                {".asf", "video/x-ms-asf"},
                {".asx", "video/x-ms-asf"},
                {".avi", "video/x-msvideo"},
                {".bin", "application/octet-stream"},
                {".cco", "application/x-cocoa"},
                {".crt", "application/x-x509-ca-cert"},
                {".css", "text/css"},
                {".deb", "application/octet-stream"},
                {".der", "application/x-x509-ca-cert"},
                {".dll", "application/octet-stream"},
                {".dmg", "application/octet-stream"},
                {".ear", "application/java-archive"},
                {".eot", "application/octet-stream"},
                {".exe", "application/octet-stream"},
                {".flv", "video/x-flv"},
                {".gif", "image/gif"},
                {".hqx", "application/mac-binhex40"},
                {".htc", "text/x-component"},
                {".htm", "text/html"},
                {".html", "text/html"},
                {".ico", "image/x-icon"},
                {".img", "application/octet-stream"},
                {".iso", "application/octet-stream"},
                {".jar", "application/java-archive"},
                {".jardiff", "application/x-java-archive-diff"},
                {".jng", "image/x-jng"},
                {".jnlp", "application/x-java-jnlp-file"},
                {".jpeg", "image/jpeg"},
                {".jpg", "image/jpeg"},
                {".js", "application/x-javascript"},
                {".mml", "text/mathml"},
                {".mng", "video/x-mng"},
                {".mov", "video/quicktime"},
                {".mp3", "audio/mpeg"},
                {".mpeg", "video/mpeg"},
                {".mpg", "video/mpeg"},
                {".msi", "application/octet-stream"},
                {".msm", "application/octet-stream"},
                {".msp", "application/octet-stream"},
                {".pdb", "application/x-pilot"},
                {".pdf", "application/pdf"},
                {".pem", "application/x-x509-ca-cert"},
                {".pl", "application/x-perl"},
                {".pm", "application/x-perl"},
                {".png", "image/png"},
                {".prc", "application/x-pilot"},
                {".ra", "audio/x-realaudio"},
                {".rar", "application/x-rar-compressed"},
                {".rpm", "application/x-redhat-package-manager"},
                {".rss", "text/xml"},
                {".run", "application/x-makeself"},
                {".sea", "application/x-sea"},
                {".shtml", "text/html"},
                {".sit", "application/x-stuffit"},
                {".swf", "application/x-shockwave-flash"},
                {".tcl", "application/x-tcl"},
                {".tk", "application/x-tcl"},
                {".txt", "text/plain"},
                {".war", "application/java-archive"},
                {".wbmp", "image/vnd.wap.wbmp"},
                {".wmv", "video/x-ms-wmv"},
                {".xhtml", "application/xhtml+xml" },
                {".xml", "text/xml"},
                {".xpi", "application/x-xpinstall"},
                {".zip", "application/zip"},

                #endregion
            };

        public WebServer(IReadOnlyCollection<string> prefixes, Func<HttpListenerRequest, Scripting.Dictionary, Scripting.Dictionary, Scripting.Dictionary, string> method)
        {
            if (!HttpListener.IsSupported)
            {
                throw new NotSupportedException("Needs Windows XP SP2, Server 2003 or later.");
            }

            // URI prefixes are required eg: "http://localhost:8080/test/"
            if (prefixes == null || prefixes.Count == 0)
            {
                throw new ArgumentException("URI prefixes are required");
            }

            if (method == null)
            {
                throw new ArgumentException("responder method required");
            }

            foreach (var s in prefixes)
            {
                _listener.Prefixes.Add(s);
            }

            _responderMethod = method;
            _listener.Start();
        }

        public WebServer(Func<HttpListenerRequest, Scripting.Dictionary, Scripting.Dictionary, Scripting.Dictionary, string> method, params string[] prefixes)
           : this(prefixes, method)
        {
        }

        public void Run()
        {
            ThreadPool.QueueUserWorkItem(o =>
            {
                Console.WriteLine("Webserver running...");
                try
                {
                    while (_listener.IsListening)
                    {
                        ThreadPool.QueueUserWorkItem(c =>
                        {
                            var ctx = c as HttpListenerContext;
                            try
                            {
                                if (ctx == null)
                                {
                                    return;
                                }


                                string localpathOs = ctx.Request.Url.LocalPath.Replace("/", "\");
                                string path = "N:\html" + localpathOs; 
                                string ext = System.IO.Path.GetExtension(path);



                                if (ext.Length > 0)
                                {
                                    /* a static file has been requested so serve it
                                     *
                                     * With thanks to L.B. https://stackoverflow.com/users/932418/l-b
                                     * https://stackoverflow.com/questions/13385633/serving-large-files-with-c-sharp-httplistener
                                     *
                                     * Also with thanks to Caio Proiete https://gist.github.com/caioproiete
                                     * https://gist.github.com/caioproiete/0a22dd020045a0fee239
                                     */
                                    if (!System.IO.File.Exists(path))
                                    {
                                        ctx.Response.StatusCode = (int)HttpStatusCode.NotFound;
                                    }
                                    else
                                    {

                                        using (FileStream fs = System.IO.File.OpenRead(path))
                                        {
                                            string filename = Path.GetFileName(path);
                                            //response is HttpListenerContext.Response...
                                            ctx.Response.ContentLength64 = fs.Length;
                                            ctx.Response.SendChunked = false;

                                            string mime;
                                            ctx.Response.ContentType = _mimeTypeMappings.TryGetValue(Path.GetExtension(filename), out mime)
                                                ? mime
                                                : "application/octet-stream";

                                            byte[] buffer = new byte[64 * 1024];
                                            int read;
                                            using (BinaryWriter bw = new BinaryWriter(ctx.Response.OutputStream))
                                            {
                                                while ((read = fs.Read(buffer, 0, buffer.Length)) > 0)
                                                {
                                                    bw.Write(buffer, 0, read);
                                                    bw.Flush(); //seems to have no effect
                                                }

                                                bw.Close();
                                            }

                                            ctx.Response.StatusCode = (int)HttpStatusCode.OK;
                                            ctx.Response.StatusDescription = "OK";
                                            ctx.Response.OutputStream.Close();
                                        }
                                    }
                                }
                                else
                                {
                                    /* a non-static file has been requested so we assume it is a REST request
                                     * and will route it to our Excel VBA server
                                     */

                                    try
                                    {
                                        Scripting.Dictionary dicResponseHeaders = new Scripting.Dictionary(); // this is to be populated by the Excel VBA
                                        Scripting.Dictionary dicResponseCookies = new Scripting.Dictionary(); // this is to be populated by the Excel VBA
                                        Scripting.Dictionary dicStatusCode = new Scripting.Dictionary(); // this is to be populated by the Excel VBA

                                        /* next we call into the VBA gateway */
                                        var rstr = _responderMethod(ctx.Request, dicResponseHeaders, dicResponseCookies, dicStatusCode);

                                        var keys = dicStatusCode.Keys();
                                        int lStatusCode = keys[0];

                                        ctx.Response.StatusCode = lStatusCode;

                                        {
                                            if (dicResponseHeaders.Count > 0)
                                            {
                                                foreach (string keyLoop in dicResponseHeaders.Keys())
                                                {
                                                    ctx.Response.Headers.Add(keyLoop, dicResponseHeaders.get_Item(keyLoop));
                                                }
                                            }

                                            if (dicResponseCookies.Count > 0)
                                            {
                                                foreach (string keyLoop in dicResponseCookies.Keys())
                                                {
                                                    string cookieValue = dicResponseCookies.get_Item(keyLoop);
                                                    Cookie cookieLoop = new Cookie(keyLoop, cookieValue);
                                                    ctx.Response.SetCookie(cookieLoop);
                                                }
                                            }

                                            if (rstr != null)
                                            {
                                                var buf = Encoding.UTF8.GetBytes(rstr);
                                                ctx.Response.ContentLength64 = buf.Length;
                                                ctx.Response.OutputStream.Write(buf, 0, buf.Length);
                                            }
                                        }
                                    }
                                    catch (Exception)
                                    {
                                        ctx.Response.StatusCode = (int)HttpStatusCode.InternalServerError;
                                    }
                                }
                            }
                            catch
                            {
                                // ignored
                            }
                            finally
                            {
                                // always close the stream
                                if (ctx != null)
                                {
                                    ctx.Response.OutputStream.Close();
                                }
                            }
                        }, _listener.GetContext());
                    }
                }
                catch (Exception)
                {
                    // ignored
                }
            });
        }

        public void Stop()
        {
            _listener.Stop();
            _listener.Close();
        }
    }


    public partial class ThisAddIn
    {
        WebServer ws = null;

        public static string SendResponse(HttpListenerRequest request, Scripting.Dictionary dicResponseHeaders, Scripting.Dictionary dicResponseCookies, Scripting.Dictionary dicStatusCode)
        {
            const string csWebServerWorkbook = "WebServer.xlsm";
            Excel.Workbook wbServer = GetWorkbookByName(csWebServerWorkbook);
            if (wbServer != null)
            {
                try
                {
                    Scripting.Dictionary dicUrlProps = new Scripting.Dictionary();

                    dicUrlProps.Add("AbsolutePath", request.Url.AbsolutePath);
                    dicUrlProps.Add("AbsoluteUri", request.Url.AbsoluteUri);
                    dicUrlProps.Add("Authority", request.Url.Authority);
                    dicUrlProps.Add("DnsSafeHost", request.Url.DnsSafeHost);
                    dicUrlProps.Add("Fragment", request.Url.Fragment);
                    dicUrlProps.Add("Host", request.Url.Host);
                    dicUrlProps.Add("HostNameType", request.Url.HostNameType.ToString());
                    dicUrlProps.Add("IdnHost", request.Url.IdnHost);
                    dicUrlProps.Add("IsAbsoluteUri", request.Url.IsAbsoluteUri);
                    dicUrlProps.Add("IsDefaultPort", request.Url.IsDefaultPort);
                    dicUrlProps.Add("IsFile", request.Url.IsFile);
                    dicUrlProps.Add("IsLoopback", request.Url.IsLoopback);
                    dicUrlProps.Add("IsUnc", request.Url.IsUnc);
                    dicUrlProps.Add("IsWellFormedOriginalString", request.Url.IsWellFormedOriginalString());
                    dicUrlProps.Add("LocalPath", request.Url.LocalPath);
                    dicUrlProps.Add("OriginalString", request.Url.OriginalString);
                    dicUrlProps.Add("PathAndQuery", request.Url.PathAndQuery);
                    dicUrlProps.Add("Port", request.Url.Port);
                    dicUrlProps.Add("Query", request.Url.Query);
                    dicUrlProps.Add("Scheme", request.Url.Scheme);

                    Scripting.Dictionary dicUrlSegments = new Scripting.Dictionary();
                    foreach (string segmentLoop in request.Url.Segments)
                    {
                        dicUrlSegments.Add(dicUrlSegments.Count, segmentLoop);
                    }
                    dicUrlProps.Add("Segments", dicUrlSegments);
                    dicUrlProps.Add("ToString", request.Url.ToString());
                    dicUrlProps.Add("UserEscaped", request.Url.UserEscaped);
                    dicUrlProps.Add("UserInfo", request.Url.UserInfo);

                    Scripting.Dictionary dicQueryString = new Scripting.Dictionary();
                    foreach (string keyLoop in request.QueryString.Keys)
                    {
                        dicQueryString.Add(keyLoop, request.QueryString[keyLoop]);
                    }

                    Scripting.Dictionary dicRequestHeaders = new Scripting.Dictionary();
                    foreach (string headerKeyLoop in request.Headers.Keys)
                    {
                        dicRequestHeaders.Add(headerKeyLoop, request.Headers[headerKeyLoop]);
                    }


                    byte[] postData = null;
                    if (request.HasEntityBody)
                    {
                        //https://stackoverflow.com/questions/3434007/error-this-stream-does-not-support-seek-operations-in-c-sharp#3434077
                        using (Stream stream = request.InputStream)
                        using (MemoryStream ms = new MemoryStream())
                        {
                            int count = 0;
                            do
                            {
                                byte[] buf = new byte[1024];
                                count = stream.Read(buf, 0, 1024);
                                ms.Write(buf, 0, count);
                            } while (stream.CanRead && count > 0);
                            postData = ms.ToArray();
                        }

                    }
                    else
                    {
                        // it seems we have to pass something ...
                        postData = new byte[0];
                    }


                    Scripting.Dictionary dicRequestCookies = new Scripting.Dictionary();
                    foreach (Cookie cookieLoop in request.Cookies)
                    {
                        dicRequestCookies.Add(cookieLoop.Name, cookieLoop.Value);
                    }

                    string responseText;
                    responseText = Globals.ThisAddIn.Application.Run(csWebServerWorkbook + "!HttpRequest", dicUrlProps, request.HttpMethod,
                            dicQueryString, request.HasEntityBody, postData, dicRequestHeaders, dicRequestCookies, dicResponseHeaders, dicResponseCookies, dicStatusCode);
                    if (dicStatusCode.Count == 0)
                    {
                        dicStatusCode.Add(500, 0);
                    }
                    return responseText;
                }
                catch (COMException ex)
                {
                    if (ex.Message.Contains("macros may be disabled"))
                    {
                        dicStatusCode.Add(500, 0);
                        return ex.Message;
                    }
                    else
                    {
                        dicStatusCode.Add(500, 0);
                        return ex.Message;
                    }
                }

                catch (Exception ex)
                {
                    dicStatusCode.Add(500, 0);
                    return ex.Message;
                }
            }
            else
            {
                dicStatusCode.Add(500, 0);
                return string.Format("<HTML><BODY>Error:" + csWebServerWorkbook + " is not running!<br>{0}</BODY></HTML>", DateTime.Now);
            }
        }

        private static Excel.Workbook GetWorkbookByName(string wbName)
        {
            Excel.Workbook wbReturn = null;
            foreach (Excel.Workbook wbLoop in Globals.ThisAddIn.Application.Workbooks)
            {
                if (wbLoop.Name == wbName)
                {
                    wbReturn = wbLoop;
                }
            }
            return wbReturn;
        }

        private void ThisAddIn_Startup(object sender, System.EventArgs e)
        {
            ws = new WebServer(SendResponse, "http://localhost:8080/theFooBar/");
            ws.Run();

        }

        private void ThisAddIn_Shutdown(object sender, System.EventArgs e)
        {
            ws.Stop();
        }

        #region VSTO generated code

        /// <summary>
        /// Required method for Designer support - do not modify
        /// the contents of this method with the code editor.
        /// </summary>
        private void InternalStartup()
        {
            this.Startup += new System.EventHandler(ThisAddIn_Startup);
            this.Shutdown += new System.EventHandler(ThisAddIn_Shutdown);
        }

        #endregion
    }
}

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