SIBAINUのメモ帳

インターフェイスを使ったコントロールのイベント管理クラス

フォームのモジュールに記述するイベント管理クラスの生成とインターフェイスからコールバックされる関数群

オブジェクトの作成：インターフェイス AllEventsIF とフォーム 
　　　　　　　　　　→ クラス AllEventsControl
　　　　　　　　　　→ インターフェイス AllSinkIFとクラス AllEvents 
　　　　　　　　　　→ クラス AllSink 
イベント処理：クラス AllSink 
　　　　　　　　　　→ インターフェイス AllSinkIF 
　　　　　　　　　　→ クラス AllEvents 
　　　　　　　　　　→ インターフェイス AllEventsIF 
　　　　　　　　　　→ フォームのコールバック関数

COPY

Option Explicit

Implements AllEventsIF
Private myControl           As AllEventControls

'--------------------フォームを開く
Private Sub UserForm_Initialize()

    Set myControl = New AllEventControls       ' インスタンスの生成
    With myControl
        .Parent = Me
        .Init
    End With

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

End Sub

'--------------------インターフェイスからコールバックされるメンバ関数
Private Sub AllEventsIF_onAfterUpdate(Cont As MSForms.IControl)

End Sub

Private Sub AllEventsIF_onBeforeUpdate(Cont As MSForms.IControl, _
                                       ByVal Cancel As MSForms.IReturnBoolean)

End Sub

Private Sub AllEventsIF_onChange(Cont As MSForms.IControl)

End Sub

Private Sub AllEventsIF_onClick(Cont As MSForms.IControl)

End Sub

Private Sub AllEventsIF_onDblClick(Cont As MSForms.IControl, _
                                   ByVal Cancel As MSForms.IReturnBoolean)

End Sub

Private Sub AllEventsIF_onDropButtonClick(Cont As MSForms.IControl)

End Sub

Private Sub AllEventsIF_onEnter(Cont As MSForms.IControl)

End Sub

Private Sub AllEventsIF_onExit(Cont As MSForms.IControl, _
                               ByVal Cancel As MSForms.IReturnBoolean)

End Sub

Private Sub AllEventsIF_onKeyDown(Cont As MSForms.IControl, _
                                  ByVal KeyCode As MSForms.IReturnInteger, _
                                  ByVal Shift As Integer)

End Sub

Private Sub AllEventsIF_onKeyPress(Cont As MSForms.IControl, _
                                   ByVal KeyAscii As MSForms.IReturnInteger)

End Sub

Private Sub AllEventsIF_onKeyUp(Cont As MSForms.IControl, _
                                ByVal KeyCode As MSForms.IReturnInteger, _
                                ByVal Shift As Integer)

End Sub

Private Sub AllEventsIF_onListClick(Cont As MSForms.IControl)

End Sub

Private Sub AllEventsIF_onMouseDown(Cont As MSForms.IControl, _
                                    ByVal Button As Integer, _
                                    ByVal Shift As Integer, _
                                    ByVal X As Single, _
                                    ByVal Y As Single)

End Sub

Private Sub AllEventsIF_onMouseMove(Cont As MSForms.IControl, _
                                    ByVal Button As Integer, _
                                    ByVal Shift As Integer, _
                                    ByVal X As Single, _
                                    ByVal Y As Single)

End Sub

Private Sub AllEventsIF_onMouseUp(Cont As MSForms.IControl, _
                                  ByVal Button As Integer, _
                                  ByVal Shift As Integer, _
                                  ByVal X As Single, _
                                  ByVal Y As Single)

End Sub

フォームのインターフェイス AllEventsIF

インターフェイスなので関数の外観のみです。

COPY

Option Explicit

Public Sub onChange(Cont As MSForms.Control)
End Sub

Public Sub onListClick(Cont As MSForms.Control)
End Sub

Public Sub onClick(Cont As MSForms.Control)
End Sub

Public Sub onDropButtonClick(Cont As MSForms.Control)
End Sub

Public Sub onDblClick(Cont As MSForms.Control, _
                      ByVal Cancel As MSForms.ReturnBoolean)
End Sub

Public Sub onKeyDown(Cont As MSForms.Control, _
                     ByVal KeyCode As MSForms.ReturnInteger, _
                     ByVal Shift As Integer)
End Sub

Public Sub onKeyUp(Cont As MSForms.Control, _
                   ByVal KeyCode As MSForms.ReturnInteger, _
                   ByVal Shift As Integer)
End Sub

Public Sub onMouseDown(Cont As MSForms.Control, _
                       ByVal Button As Integer, _
                       ByVal Shift As Integer, _
                       ByVal X As Single, _
                       ByVal Y As Single)
End Sub

Public Sub onMouseMove(Cont As MSForms.Control, _
                       ByVal Button As Integer, _
                       ByVal Shift As Integer, _
                       ByVal X As Single, _
                       ByVal Y As Single)
End Sub

Public Sub onMouseUp(Cont As MSForms.Control, _
                     ByVal Button As Integer, _
                     ByVal Shift As Integer, _
                     ByVal X As Single, _
                     ByVal Y As Single)
End Sub

Public Sub onKeyPress(Cont As MSForms.Control, _
                      ByVal KeyAscii As MSForms.ReturnInteger)
End Sub

Public Sub onExit(Cont As MSForms.Control, _
                  ByVal Cancel As MSForms.ReturnBoolean)
End Sub

Public Sub onAfterUpdate(Cont As MSForms.Control)
End Sub

Public Sub onBeforeUpdate(Cont As MSForms.Control, _
                          ByVal Cancel As MSForms.ReturnBoolean)
End Sub

Public Sub onEnter(Cont As MSForms.Control)
End Sub

個々のコントールのイベントクラスを管理するクラス AllEventsControl

プロパティを経由して取得したフォーム上のすべてのコントロールを対象にしています。

COPY

Option Explicit

Private myParent            As Object
Private myList              As Dictionary

Public Property Get Parent() As Object
    Set Parent = myParent
End Property

Public Property Let Parent(val As Object)
    Set myParent = val
End Property

Public Sub Init()
    Dim Ctrl    As MSForms.Control

    If Parent Is Nothing Then
        Exit Sub
    End If

    'コントロールの名前とクラスオブジェクトを登録
    Set myList = New Dictionary
    For Each Ctrl In Parent.Controls
        With New AllEvents
            .Parent = Parent
            .Item = Ctrl
            myList.Add Ctrl.Name, .Self
        End With
    Next Ctrl

End Sub

Private Sub Class_Terminate()
    Dim Keys                As Variant

    'リストのオブジェクトの参照を廃棄
    If Not myList Is Nothing Then
        For Each Keys In myList
            Set myList(Keys) = Nothing
        Next
    End If

End Sub

個々のコントロールのイベントを処理する AllEvnets

インターフェイスを通してフォームのコールバック関数を実行します。

コールバック関数にこれ以上記述することはありません。詳細はフォームのコールバック関数に記述します。
インターフェイス AllSinkIF のコールバック関数でもあります。

COPY

Option Explicit
'API定義 [ ConnectToConnectionPoint ]
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" _
             (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, _
             ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, _
             ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
#Else
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" _
             (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, _
             ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, _
             ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
#End If

Private Cookie As Long

Implements AllSinkIF
Private Caller              As AllEventsIF
Private EventSink           As AllSink
Private MyCtrl              As Object

Public Property Get Item() As Object
    Set Item = MyCtrl
End Property
 
Public Property Let Item(Ctrl As Object)
    Set MyCtrl = Ctrl
    Call ConnectEvent(True)
End Property
 
Public Property Get Parent() As Object
    Set Parent = Caller
End Property
  
Public Property Let Parent(val As Object)
    Set Caller = val
End Property
   
Public Property Get Self() As Object
    Set Self = Me
End Property

Private Sub Class_Initialize()

    Set EventSink = New AllSink
    With EventSink
        .CParent = Me
    End With

End Sub

Private Sub Class_Terminate()

    Call Clear

End Sub

Public Sub Clear()

    If (Cookie <> 0) Then
        Call ConnectEvent(False)
    End If

    Set MyCtrl = Nothing
    Set EventSink = Nothing

End Sub

Private Sub ConnectEvent(ByVal Connect As Boolean)
    Dim IID_IDispatch As GUID

    ' GUID {00020400-0000-0000-C000000000000046}
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    Call ConnectToConnectionPoint(EventSink, _
                                  IID_IDispatch, _
                                  Connect, _
                                  MyCtrl, _
                                  Cookie, _
                                  0&)
End Sub

'--------------------コールバック関数群
Private Sub AllSinkIF_onAfterUpdate()
    Call Parent.onAfterUpdate(Item)
End Sub

Private Sub AllSinkIF_onBeforeUpdate(ByVal Cancel As MSForms.IReturnBoolean)
    Call Parent.onBeforeUpdate(Item, Cancel)
End Sub

Private Sub AllSinkIF_onChange()
    Call Parent.onChange(Item)
End Sub

Private Sub AllSinkIF_onClick()
    Call Parent.onClick(Item)
End Sub

Private Sub AllSinkIF_onDblClick(ByVal Cancel As MSForms.IReturnBoolean)
    Call Parent.onDblClick(Item, Cancel)
End Sub

Private Sub AllSinkIF_onDropButtonClick()
    Call Parent.onDropButtonClick(Item)
End Sub

Private Sub AllSinkIF_onEnter()
    Call Parent.onEnter(Item)
End Sub

Private Sub AllSinkIF_onExit(ByVal Cancel As MSForms.IReturnBoolean)
    Call Parent.onExit(Item, Cancel)
End Sub

Private Sub AllSinkIF_onKeyDown(ByVal KeyCode As MSForms.IReturnInteger, ByVal Shift As Integer)
    Call Parent.onKeyDown(Item, KeyCode, Shift)
End Sub

Private Sub AllSinkIF_onKeyPress(ByVal KeyAscii As MSForms.IReturnInteger)
    Call Parent.onKeyPress(Item, KeyAscii)
End Sub

Private Sub AllSinkIF_onKeyUp(ByVal KeyCode As MSForms.IReturnInteger, ByVal Shift As Integer)
    Call Parent.onKeyUp(Item, KeyCode, Shift)
End Sub

Private Sub AllSinkIF_onListClick()
    Call Parent.onListClick(Item)
End Sub

Private Sub AllSinkIF_onMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Parent.onMouseDown(Item, Button, Shift, X, Y)
End Sub

Private Sub AllSinkIF_onMouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Parent.onMouseMove(Item, Button, Shift, X, Y)
End Sub

Private Sub AllSinkIF_onMouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Parent.onMouseUp(Item, Button, Shift, X, Y)
End Sub

コントロールのイベントを受け処理する AllSink

COPY

Option Explicit

Private memCParent          As AllSinkIF

Public Property Let CParent(val As Object)
    Set memCParent = val
End Property

Public Property Get CParent() As Object
    'インターフェイスで受けます。
    Set CParent = memCParent
End Property

'--------------------コールバック関数群
Public Sub onChange()
Attribute onChange.VB_UserMemId = 2
'Attribute onChange.VB_UserMemId = 2
    Call CParent.onChange
End Sub

Public Sub onListClick()
Attribute onListClick.VB_UserMemId = -610
'Attribute onListClick.VB_UserMemId = -610
    Call CParent.onListClick
End Sub

Public Sub onClick()
Attribute onClick.VB_UserMemId = -600
'Attribute onClick.VB_UserMemId = -600
    Call CParent.onClick
End Sub

Public Sub onDropButtonClick()
Attribute onDropButtonClick.VB_UserMemId = 2002
'Attribute onDropButtonClick.VB_UserMemId = 2002
    Call CParent.onDropButtonClick
End Sub

Public Sub onDblClick(ByVal Cancel As MSForms.ReturnBoolean)
Attribute onDblClick.VB_UserMemId = -601
'Attribute onDblClick.VB_UserMemId = -601
    Call CParent.onDblClick(Cancel)
End Sub

Public Sub onKeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                     ByVal Shift As Integer)
Attribute onKeyDown.VB_UserMemId = -602
'Attribute onKeyDown.VB_UserMemId = -602
    Call CParent.onKeyDown(KeyCode, Shift)
End Sub

Public Sub onKeyUp(ByVal KeyCode As MSForms.ReturnInteger, _
                   ByVal Shift As Integer)
Attribute onKeyUp.VB_UserMemId = -604
'Attribute onKeyUp.VB_UserMemId = -604
    Call CParent.onKeyUp(KeyCode, Shift)
End Sub

Public Sub onMouseDown(ByVal Button As Integer, _
                       ByVal Shift As Integer, _
                       ByVal X As Single, _
                       ByVal Y As Single)
Attribute onMouseDown.VB_UserMemId = -605
'Attribute onMouseDown.VB_UserMemId = -605
    Call CParent.onMouseDown(Button, Shift, X, Y)
End Sub

Public Sub onMouseMove(ByVal Button As Integer, _
                       ByVal Shift As Integer, _
                       ByVal X As Single, _
                       ByVal Y As Single)
Attribute onMouseMove.VB_UserMemId = -606
'Attribute onMouseMove.VB_UserMemId = -606
    Call CParent.onMouseMove(Button, Shift, X, Y)
End Sub

Public Sub onMouseUp(ByVal Button As Integer, _
                     ByVal Shift As Integer, _
                     ByVal X As Single, _
                     ByVal Y As Single)
Attribute onMouseUp.VB_UserMemId = -607
'Attribute onMouseUp.VB_UserMemId = -607
    Call CParent.onMouseUp(Button, Shift, X, Y)
End Sub

Public Sub onKeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Attribute onKeyPress.VB_UserMemId = -603
'Attribute onKeyPress.VB_UserMemId = -603
    Call CParent.onKeyPress(KeyAscii)
End Sub

Public Sub onExit(ByVal Cancel As MSForms.ReturnBoolean)
Attribute onExit.VB_UserMemId = -2147384829
'Attribute onExit.VB_UserMemId = -2147384829
    Call CParent.onExit(Cancel)
End Sub

Public Sub onAfterUpdate()
Attribute onAfterUpdate.VB_UserMemId = -2147384832
'Attribute onAfterUpdate.VB_UserMemId = -2147384832
    Call CParent.onAfterUpdate
End Sub

Public Sub onBeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Attribute onBeforeUpdate.VB_UserMemId = -2147384831
'Attribute onBeforeUpdate.VB_UserMemId = -2147384831
    Call CParent.onBeforeUpdate(Cancel)
End Sub

Public Sub onEnter()
Attribute onEnter.VB_UserMemId = -2147384830
'Attribute onEnter.VB_UserMemId = -2147384830
    Call CParent.onEnter
End Sub

クラス AllEvents のインターフェイス AllSink

インターフェイスなので関数の外観のみです。
インターフェイスを通してクラス AllEvents のコールバック関数群を実行します。

COPY

Option Explicit

Public Sub onChange()

End Sub

Public Sub onListClick()

End Sub

Public Sub onClick()

End Sub

Public Sub onDropButtonClick()

End Sub

Public Sub onDblClick(ByVal Cancel As MSForms.ReturnBoolean)

End Sub

Public Sub onKeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                     ByVal Shift As Integer)

End Sub

Public Sub onKeyUp(ByVal KeyCode As MSForms.ReturnInteger, _
                   ByVal Shift As Integer)

End Sub

Public Sub onMouseDown(ByVal Button As Integer, _
                       ByVal Shift As Integer, _
                       ByVal X As Single, _
                       ByVal Y As Single)

End Sub

Public Sub onMouseMove(ByVal Button As Integer, _
                       ByVal Shift As Integer, _
                       ByVal X As Single, _
                       ByVal Y As Single)

End Sub

Public Sub onMouseUp(ByVal Button As Integer, _
                     ByVal Shift As Integer, _
                     ByVal X As Single, _
                     ByVal Y As Single)

End Sub

Public Sub onKeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

End Sub

Public Sub onExit(ByVal Cancel As MSForms.ReturnBoolean)

End Sub

Public Sub onAfterUpdate()

End Sub

Public Sub onBeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

End Sub

Public Sub onEnter()

End Sub

COPY