はじめに

以前、こちらの記事で64bit環境のVBAでScriptControlを無理矢理使う方法を紹介しました。

しかし、特定用途（例：JScriptのfunctionオブジェクトをVBAからインスタンスする）であればより簡単かつ堅牢な方法があったため、備忘録も兼ねて記事にします。

functionオブジェクトのインスタンス用関数

コード

'Instance JScript Function object

'e.g.
    'Dim adder As Object: Set adder = JSFunc("a,b", "a+b") 'autoReturn = True
    'Debug.Print adder(2, 6) '->8

    'Dim inRange As Object
    'Set inRange = JSFunc("range,min,max", "v=range.Value;return min<=v&&v<=max;", False) 'autoReturn = False
    'Excel.ActiveCell.Value() = 150
    'Debug.Print inRange(Excel.ActiveCell, 100, 200) '->True

'Arguments
'args
    '`funcBody`内で使用する引数。
    '複数指定時はカンマ区切りで指定する。
    '参考:'[Function - JavaScript | MDN](https://developer.mozilla.org/ja/docs/Web/JavaScript/Reference/Global_Objects/Function)
'funcBody
    '関数本文。
'autoReturn
    '省略可能。省略時True。
    'Trueのとき`funcBody`の先頭に`return `を追加する。

'Return
    'インスタンスされたJScriptのfunctionオブジェクト。

Function JSFunc( _
        args As String, _
        funcBody As String, _
        Optional autoReturn As Boolean = True) As Object

    Const EXEC_SCRIPT = _
            "this.createFunc=" & _
                "function(args,funcBody){" & _
                    "return new Function(args,funcBody);}"

    '各種初期化
    '関数オブジェクトのキャッシュ
    Static funcCache As Object 'As Scripting.Dictionary
    If funcCache Is Nothing Then Set funcCache = VBA.CreateObject("Scripting.Dictionary")

    'JScript実行環境。参照を保持しないとインスタンスしたfunctionオブジェクトも消える
    Static htmlDoc    As Object 'As MSHTML.HTMLDocument
    Static createFunc As Object 'JScript function
    
    If htmlDoc Is Nothing Then
        Call funcCache.RemoveAll
        Set htmlDoc = VBA.CreateObject("htmlfile")
        
        'JScriptのグローバル変数に関数を定義
        Call htmlDoc.parentWindow.execScript(EXEC_SCRIPT)
        
        '作成した関数を静的変数に保管（書き換え防止）
        Set createFunc = htmlDoc.parentWindow.createFunc
    End If


    'キャッシュ用に整形
    Dim trimedArgs As String, trimedBody As String
    trimedArgs = VBA.Trim$(args)
    If autoReturn Then
        trimedBody = "return " & VBA.Trim$(funcBody)
    Else
        trimedBody = VBA.Trim$(funcBody)
    End If

    Dim cacheKey As String
    cacheKey = trimedArgs & "|" & trimedBody


    'キャッシュに無ければ新規インスタンス
    If Not funcCache.Exists(cacheKey) Then
        Call funcCache.Add(cacheKey, createFunc(trimedArgs, trimedBody))
    End If

    Set JSFunc = funcCache.Item(cacheKey)

End Function

やっていること

JScript実行環境の用意

JScriptの実行環境としてScriptControlの代わりに、IEのエンジンであるMSHTML（Microsoft HTML Object Library）を使用しています。

ScriptControl は64bitVBAではインスタンスできませんが、MSHTMLはOfficeがインストールされていれば大体使用できるはずです（MS Office 2010 32bit・MS Office 2016 64bitで確認）。

関数作成関数の定義

MSHTML.HTMLWindow2オブジェクトのexecScriptメソッドを使用すれば任意のスクリプトを実行できますが、実行結果を直接受け取ることはできません。

そのため、代替手段として「JScriptのグローバル変数はルートオブジェクトのプロパティとなる」ことを利用します。

execScriptで必要なものを作成・グローバル変数に設定し、ルートオブジェクトのプロパティから作成したものを取得します。

'グローバル変数に定義
Call htmlDoc.parentWindow.execScript(EXEC_SCRIPT)
'ルートオブジェクトのプロパティから取得
Set createFunc = htmlDoc.parentWindow.createFunc

関数作成関数(EXEC_SCRIPT)

this.createFunc=
    function(args,funcBody){
        return new Function(args,funcBody);}

その他の部分は効率化などのために追加したものになります。

使用例

普通の計算

Sub FuncSample()
    
    Dim multiply As Object
    Set multiply = JSFunc("a,b", "a*b")
    
    Debug.Print multiply 'function anonymous(a,b) {return a*b}
    
    Debug.Print multiply(3, 5) '15
    Debug.Print multiply(7, 9) '63
    
End Sub

オブジェクトの操作

'Excel用 シート名の一覧を出力する
Sub FuncSample2()
    Dim getName As Object
    Set getName = JSFunc("o", "o.Name")
    
    Debug.Print getName 'function anonymous(o) {return o.Name}
    
    Dim s As Object
    For Each s In Excel.ThisWorkbook.Sheets
        Debug.Print getName(s)
    Next s
    
End Sub

列挙子を使用

Sub EnumeratorSample()
    
    '適当なコレクションを用意
    Dim col As VBA.Collection
    Set col = New VBA.Collection
    col.Add 1
    col.Add "ABC"
    col.Add Now
    
    Dim Enumerator As Object
    Set Enumerator = JSFunc("col", "new Enumerator(col)")
    
    'JScriptのEnumeratorオブジェクトをインスタンス
    Dim e As Object
    Set e = Enumerator(col)
    
    '`.atEnd()`だとfunctionオブジェクトが返るため、適当な引数を指定するか、CallByNameを使う
    Do While Not e.atEnd(Nothing)
        
        'メソッド名の大文字・小文字を区別するため、CallByNameを使う
        Debug.Print CallByName(e, "item", VbMethod)
        Call e.moveNext
        
    Loop
    
End Sub

参考：速度比較

'処理速度比較用
Sub SpeedTest()
    
    Dim startTime As Single
    Const LOOP_COUNT = 100000
    Dim i As Long, buf As String
    
    Debug.Print VBA.Format$(LOOP_COUNT, "0,0"); "回実行した結果"
    
    '通常のプロパティ参照
    startTime = VBA.Timer
    For i = 1 To LOOP_COUNT
        buf = Excel.ThisWorkbook.Name
    Next i
    Debug.Print "Normal", VBA.Timer - startTime
    
    'CallByName
    startTime = VBA.Timer
    For i = 1 To LOOP_COUNT
        buf = VBA.CallByName(Excel.ThisWorkbook, "Name", VbGet)
    Next i
    Debug.Print "CallByName", VBA.Timer - startTime
    
    'function
    startTime = VBA.Timer
    Dim getName As Object
    Set getName = JSFunc("o", "o.Name")
    For i = 1 To LOOP_COUNT
        buf = getName(Excel.ThisWorkbook)
    Next i
    Debug.Print "function", VBA.Timer - startTime
    
End Sub

作者環境で上のコードを実行すると以下の結果となりました。

100,000回実行した結果
Normal         0.109375
CallByName     0.625
function       1.289063

処理内容にもよりますが、速度の要求がそこまでで無ければアリな気はします。