[VBA] Application.OnTimeを使用せずにプロシージャ／メソッドを指定時間経過後にコールバックする方法

0.README.md

[VBA] Application.OnTimeを使用せずにプロシージャ／メソッドを指定時間経過後にコールバックする方法

Application.OnTimeは標準モジュールのプロシージャもしくはThisWorkbookやSheet1等のCodeNameを持つオブジェクトのメソッドしか実行（コールバック）できません。
任意オブジェクトのメソッドをコールバックができないか？ と思っていたのですが、Microsoft HTML Object Library で使用できる JScript を利用すればできそうに思えたので試してみました。

ライブラリ用標準モジュール（Mod_Callback.vba）のコードを標準モジュールとして貼り付けると、以下のプロシージャが使用可能となります。

なお、SetTimerとSetCallbackでは引数の指定方法が異なるだけで、機能的には同等です（待ち時間の単位がSetTimerはミリ秒(Long型)、SetCallbackでは秒(Double型)なので注意）。
※最初にSetCallbackを作った後、引数の指定方法がやや煩雑かも？と思いつつ、同じプロシージャ名で引数だけ変えると互換性の問題が出てくるので、別プロシージャ(SetTimer)にした次第。

Public Function SetTimer(ByVal WaitMilliSeconds As Long, ByVal MethodName As String, Optional ByVal ParamObject As Variant, Optional ByVal ParentObject As Object = Nothing) As Long
指定したオブジェクトのメソッド／標準モジュールのプロシージャを指定時間経過後に実行する

引数：
  WaitMilliSeconds: コールバックさせるまでの時間（ミリ秒）
  MethodName: コールバックさせる標準モジュールのプロシージャ名もしくはメソッド名（文字列）※メソッド名はParentObject指定時
  ParamObject(オプション): コールバック時にパラメータとして渡すオブジェクト（Collection や Dictionary 等、文字列や数値も可能）
  ParentObject(オプション): コールバックさせたいメソッドを持つオブジェクト・Nothing指定時は標準モジュールとみなす

戻り値： タイマーID
  ※該当コールバック識別用のIDとして使用

Public Function SetCallback(ByVal ParentObject As Object, ByVal MethodName As String, ByVal WaitSec As Double, Optional ByVal ParamObject As Variant) As Long
指定したオブジェクトのメソッド／標準モジュールのプロシージャを指定時間経過後に実行する

引数：
  ParentObject: コールバックさせたいメソッドを持つオブジェクト・Nothing指定時は標準モジュールとみなす
  MethodName: コールバックさせる標準モジュールのプロシージャ名もしくはメソッド名（文字列）※メソッド名はParentObject指定時
  WaitSec: コールバックさせるまでの時間（秒）（※小数指定可）
  ParamObject(オプション): コールバック時にパラメータとして渡すオブジェクト（Collection や Dictionary 等、文字列や数値も可能）

戻り値： タイマーID
  ※該当コールバック識別用のIDとして使用

Public Function OnTimeEx(EarliestTime As Variant, Procedure As String, Optional ByVal ParamObject As Variant) As Long
指定した標準モジュールのプロシージャを指定時間に実行する
※Application.OnTimeからの置換用、ただしProcedure内での引数指定（"'<プロシージャ名> ""<引数>""'"、これは引数をParamObjectとして別に指定することで対応のこと）や、LatestTime、Scheduleパラメーターは未サポート

引数：
  EarliestTime: プロシージャを実行する時刻
  Procedure: 実行するプロシージャ名
  ParamObject(オプション): 実行時にパラメータとして渡すオブジェクト（Collection や Dictionary 等、文字列や数値も可能）

戻り値： タイマーID
  ※該当コールバック識別用のIDとして使用

Public Function CancelCallback(TimerId)
SetCallback() で設定したコールバックを取り消す

引数：
  TimerId: SetCallback() により返されたタイマーIDを指定

戻り値： （なし）

テスト用標準モジュール（Mod_TestCallback.vba）とテスト用クラスモジュール（Cls_TestCallback.vba）を用いてテストした結果は以下のような感じでした。

Application.OnTime で同じことをやった場合よりもコールバックの遅延が小さいような気がしなくもないですね。

参考

• メールを閉じたときに指定したフォルダに移動するOutlookマクロ | 初心者備忘録
• VBAからJScriptのfunctionオブジェクトを使用する（64bit対応） - Qiita
• [Excel][VBA] Application.Wait や Ontime では指定時刻に対しどの程度の遅延が発生するか？

Cls_TestCallback.vba

Option Explicit

Sub Callback(Result)
    Debug.Print "Obj.Callback() ";
    Result("End") = [NOW()]
    TestPrintResult Result
End Sub

Private Sub TestPrintResult(Result)
    Debug.Print _
        "[待ち時間(秒)] " & Format(Result("DelaySec"), "0.000") & _
        " [開始] " & GetTimeText(Result("Begin")) & _
        " [予定] " & GetTimeText(Result("Scheduled")) & _
        " [終了] " & GetTimeText(Result("End")) & _
        " [終了-予定(ms)] " & Round((Result("End") - Result("Scheduled")) * 86400000#)
End Sub

Private Function GetTimeText(TimeVal)
    GetTimeText = Evaluate("TEXT(" & TimeVal & ",""hh:mm:ss.000"")")
End Function

Mod_Callback.vba

Option Explicit

Public Function SetTimer(ByVal WaitMilliSeconds As Long, ByVal MethodName As String, Optional ByVal ParamObject As Variant, Optional ByVal ParentObject As Object = Nothing) As Long
    If IsMissing(ParamObject) Then
        SetTimer = JsLibrary.SetCallback(ParentObject, MethodName, WaitMilliSeconds)
    Else
        SetTimer = JsLibrary.SetCallback(ParentObject, MethodName, WaitMilliSeconds, ParamObject)
    End If
End Function

Public Function SetCallback(ByVal ParentObject As Object, ByVal MethodName As String, ByVal WaitSec As Double, Optional ByVal ParamObject As Variant) As Long
    If IsMissing(ParamObject) Then
        SetCallback = JsLibrary.SetCallback(ParentObject, MethodName, WaitSec * 1000#)
    Else
        SetCallback = JsLibrary.SetCallback(ParentObject, MethodName, WaitSec * 1000#, ParamObject)
    End If
End Function

Public Function OnTimeEx(EarliestTime As Variant, Procedure As String, Optional ByVal ParamObject As Variant) As Long
    Dim WaitSec As Double: WaitSec = (CDbl(EarliestTime) - CDbl(Date)) * 86400# - CDbl(Timer)
    If WaitSec < 0# Then WaitSec = 0#
    OnTimeEx = SetCallback(Nothing, Procedure, WaitSec, ParamObject)
End Function

Public Sub CancelCallback(ByVal TimerId As Long)
    Call JsLibrary.CancelCallback(TimerId)
End Sub

Private Property Get JsLibrary()
    Static JsDoc
    If IsEmpty(JsDoc) Then
        Set JsDoc = CreateObject("htmlfile")
        'Set JsDoc = New HTMLDocument ' 「Microsoft HTML Object Library」への参照設定が必要
        With JsDoc.parentWindow
            .ExecScript Join(VBA.Array( _
                "this.SetOfficeApp=function(OfficeApp){this.OfficeApp=OfficeApp;};", _
                "this.SetCallback=function(ParentObject, MethodName, WaitMilliSeconds, ParamObject){", _
                "    var callback;", _
                "    if (ParentObject){", _
                "        callback=function(){try{if(ParamObject!==undefined){ParentObject[MethodName](ParamObject);}else{ParentObject[MethodName]();}}catch(error){alert(error);}};", _
                "    } else {", _
                "        callback=function(){try{if(ParamObject!==undefined){OfficeApp.Run(MethodName,ParamObject);}else{OfficeApp.Run(MethodName);}}catch(error){alert(error);}};", _
                "    }", _
                "    return setTimeout(callback, WaitMilliSeconds);", _
                "};", _
                "this.CancelCallback=function(TimerId){clearTimeout(TimerId);};" _
            ), vbLf)
            .SetOfficeApp Application
        End With
    End If
    Set JsLibrary = JsDoc.parentWindow
End Property

Mod_TestCallback.vba

Option Explicit

Sub TestStdCallback()
    Dim DelayList: DelayList = VBA.Array(0, 0.001, 0.1, 0.101, 0.105, 0.109, 0.2)
    Dim DelaySec, Result
    For Each DelaySec In DelayList
        Set Result = CreateObject("Scripting.Dictionary")
        Result("DelaySec") = DelaySec
        Result("Begin") = [NOW()]
        Result("Scheduled") = [NOW()] + CDbl(DelaySec) / 86400#
        SetCallback Nothing, "StdCallback", DelaySec, Result
    Next
End Sub

Sub TestObjCallback()
    Dim Obj: Set Obj = New Cls_TestCallback
    Dim DelayList: DelayList = VBA.Array(0, 0.001, 0.1, 0.101, 0.105, 0.109, 0.2)
    Dim DelaySec, Result
    For Each DelaySec In DelayList
        Set Result = CreateObject("Scripting.Dictionary")
        Result("DelaySec") = DelaySec
        Result("Begin") = [NOW()]
        Result("Scheduled") = [NOW()] + CDbl(DelaySec) / 86400#
        SetCallback Obj, "Callback", DelaySec, Result
    Next
End Sub

Private Sub StdCallback(Result)
    Debug.Print "StdCallback() ";
    Result("End") = [NOW()]
    TestPrintResult Result
End Sub

Private Sub TestPrintResult(Result)
    Debug.Print _
        "[待ち時間(秒)] " & Format(Result("DelaySec"), "0.000") & _
        " [開始] " & GetTimeText(Result("Begin")) & _
        " [予定] " & GetTimeText(Result("Scheduled")) & _
        " [終了] " & GetTimeText(Result("End")) & _
        " [終了-予定(ms)] " & Round((Result("End") - Result("Scheduled")) * 86400000#)
End Sub

Private Function GetTimeText(TimeVal)
    GetTimeText = Evaluate("TEXT(" & TimeVal & ",""hh:mm:ss.000"")")
End Function