VBAでインターフェースを利用したコールバックで疑似イベントループを作る

注意

　今回の記事は、個人的な興味で作成した検証的なものです。
　「DoEvents」関数を利用しているため、デバック時やコールバック中の処理次第では予測できないエラーが発生する場合があります。
　この記事で紹介するコードは自己責任の範囲内で利用してください。

はじめに

　ExcelVBAでは様々なメソッド、オブジェクト、加えてイベントの利用ができます。ワークシートのイベントはもちろん、フォームの作成ではほぼイベント駆動となります。
　ですが、すでに実装されているオブジェクトに付随するイベント処理では不可能な処理も多くあります。

　そうした場合、VBAでは各オブジェクトのプロパティやWindowsの情報をループ処理で監視して条件を満たした場合に処理することになるのですが、あらかじめループ内に記述された処理以外の処理を行うことができません。

　そこで、インターフェースを利用したコールバック処理により擬似的なイベントループを実装します。

目的

ループ処理を汎用化することで 「条件判定」と「ループ処理」を分離し、条件判定の定義のみで独自イベントを実装するクラスを定義できるようにしたい。

処理フロー

１　インターフェースクラスでコールバック関数を定義
２　インターフェースを実装するオブジェクトのコールバック関数を無限ループで呼び出す

解説

疑似イベントループはIHandlerクラスとLooperモジュールから構成されます。

IHandlerクラスは下記のようにCallbackメソッドのみを定義しています。
インターフェースクラスであるため、実装クラスでImplementsし、処理を定義します。

IHandler.cls

Option Explicit
Sub CallBack()
End Sub

このインターフェースを実装したオブジェクトをAddHandlerメソッドでLooperに登録することでループ処理によるコールバックが開始されます。

IHandlerインターフェースの実装イメージ。

SomethingHandler.cls

 
Option Explicit
'IHandlerインターフェース実装を宣言
Implements IHandler

'イベントの定義
Public Event Something()

'ループから呼び出されるIHandlerインターフェースのメソッド
'PrivateにしてSomethingHandler型の変数からは隠蔽する
Private Sub IHandler_CallBack()
'ここにイベント発行のための条件判定を定義
RaiseEvent Something
End Sub

IHandler_CallBack内でRaiseEventステートメントを呼び出すことでHandlerクラスはイベントを発行します。
また、RaiseEventをせず、クラス内部で処理を完結することも可能です。

Looperモジュールは標準モジュールでイベントループを実行します。
　１　IHandlerを実装したオブジェクトをDictionaryのキーとして登録
　２　DictionaryのKeysメソッドで登録されたオブジェクトの配列を取得
　３　無限ループによって登録されたオブジェクトのCallBackメソッド呼び出し
を実行します。

また、Apllication.OnTimeによって無限ループを別プロセスで実行するために、LooperモジュールはStartメソッドを公開しています。StartメソッドはDictionaryのメモリアドレスをキーとして無限ループを開始します。

Looperのコードはこちら

Looper.bas

Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

Private LoopActive As Boolean 'Default:False
Private Handlers As Object

Public Sub Start(ByVal HandlersPtr As String)
If CLngPtr(HandlersPtr) = ObjPtr(Handlers) Then: LoopActive = True: Call Looper
End Sub

Public Sub Refresh()
If Handlers Is Nothing Then Exit Sub
LoopActive = False
Handlers.RemoveAll
Set Handlers = Nothing
End Sub

Public Sub AddHandler(ByRef Handler As IHandler)
If Handlers Is Nothing Then Set Handlers = CreateObject("Scripting.Dictionary")
If Not Handlers.Exists(Handler) Then Handlers.Add Handler, vbNullString
If Not LoopActive Then Application.OnTime Now(), "'Looper.Start """ & CStr(ObjPtr(Handlers)) & """ '"
End Sub

Public Sub RemoveHandler(ByRef Handler As IHandler)
If Handlers Is Nothing Then Exit Sub
If Handlers.Exists(Handler) Then Handlers.Remove Handler
If Handlers.Count = 0 Then LoopActive = False
End Sub

Private Sub Looper()
Dim Handles As Variant
Dim i As Long
Do
    If Not LoopActive Then Exit Do
    If Handlers Is Nothing Then Exit Do
    If Handlers.Count = 0 Then Exit Do
    Handles = Handlers.Keys
    For i = 0 To UBound(Handles)
        If Handles(i) Is Nothing Then Exit Sub
        Handles(i).CallBack
    Next
    Sleep 1&
    VBA.DoEvents
Loop
LoopActive = False
End Sub

なにができるか？

　インターフェースを実装可能なオブジェクトであればコールバックループに登録が可能です。
　つまり、Classモジュールはもとより、Worksheet、WorkBook、UserFormにも既存のイベントでは不可能な独自イベントの作成が可能になります。

　下記のサンプルコードはExcelVBAでは提供されていない処理をIHandlerインターフェースを利用して作成したサンプルクラスです。※サンプルのためエラー処理はしていません。

Sample1-マウス座標の変更でイベントを発行するクラス

MousePositionHandler.cls

Option Explicit

Implements IHandler

Private Type POINT
    x As Long
    y As Long
End Type

Private Declare PtrSafe Function GetCursorPos _
    Lib "user32" ( _
        ByRef lpPoint As POINT) As Long

Public Event MouseMove(ByVal x As Long, ByVal y As Long)
                                  
Private myPos As POINT

Private Sub IHandler_CallBack()
Dim CurrentPos As POINT: Call GetCursorPos(CurrentPos)
If (CurrentPos.x <> myPos.x) Or (CurrentPos.y <> myPos.y) Then
    myPos.x = CurrentPos.x
    myPos.y = CurrentPos.y
    RaiseEvent MouseMove(myPos.x, myPos.y)
End If
End Sub

Sample2-クリップボードに画像がセットされたらイベントを発行するクラス

ClipboardImageHandler.cls

Option Explicit

Implements IHandler

Private Declare PtrSafe Function OpenClipboard Lib "user32" (Optional ByVal hwnd As Long = 0) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

Public Event PutImage()

Private IntervalSecond As Double
Private LastEventTime As Double

Public Property Get CapInterval() As Long: CapInterval = IntervalSecond: End Property
Public Property Let CapInterval(ByVal Second As Long): IntervalSecond = Second: End Property

Private Sub Class_Initialize()
'PrintScreen押しっぱなしで複数回のイベント発行を抑制
IntervalSecond =1
OpenClipboard
EmptyClipboard
CloseClipboard
End Sub

Private Sub IHandler_CallBack()
If LastEventTime <> 0 And (VBA.Timer - LastEventTime) < IntervalSecond Then Exit Sub
Dim CBFormat As Variant
For Each CBFormat In Application.ClipboardFormats
    If CBFormat = xlClipboardFormatBitmap Then
        RaiseEvent PutImage
        LastEventTime = VBA.Timer
        OpenClipboard
        EmptyClipboard
        CloseClipboard
    End If
Next
End Sub

サンプルはGithubで公開しています。
サンプルのように条件と処理のみをクラスで実装すれば良いので 「指定セルへMouseOver2秒以上のとき～」や「Worksheetの列幅が変更されたとき～」、「キーボードの状態変化（KeyDownなど）」でもイベント発行が可能になります。
つまり、独自イベントを定義したクラスが非常に簡単に作成できるようになります。

最後に

結局なんの役に立つのか？と聞かれると、正直、業務で使えそうなのは、サンプルのようなクリップボード監視ぐらいです。
実は当初アドインとして作成したのですが、常駐させるほどの必要性がないことに気づき、あえて標準モジュールで作成しています。
おそらく、イベントループが最も効果的なのは、操作や当たり判定などの入力待ち処理がメインとなるゲームを作成する場合です。VBAでゲームを作れる人、よろしくお願いします。