ユーザーフォーム入門
第24回.イベントプロシージャーの共通化（Enter,Exit）

Excelマクロのユーザーフォームの基礎、エクセルVBAの入門解説
最終更新日：2020-01-13

第24回.イベントプロシージャーの共通化（Enter,Exit）


ユーザーフォームのVBAでは、同じイベントプロシージャーを何個も作成することが多々あります。
テキストボックスを複数個配置して同じイベント処理を実装する時、全く同じイベントプロシージャーをコピペで何個も作るといったことが必要になります。


その解決方法として前回、
第23回.イベントプロシージャーの共通化
ユーザーフォームに部品コントロールを配置していくとき、同種のコントロールを繰り返し何個も配置することは良くあります。コピペしながらようやく配置し終わったと思ったら、今度はVBAで同じイベントプロシージャーを何個も作成しなければならなくなります。
WithEventを使った方法を紹介しましたが、この中で問題点を指摘しました。
今回は、この問題点を解決する方法を紹介します。

イベントプロシージャーの共通化の問題点

前回の記事で指摘した問題点の記述抜粋

コントロールの型ごとにWithEventsが必要
WithEventsの型に指定するのは、MSFormsの当該の具体的なコントロールの型を指定します。
したがって、コントロールの種類ごとにWithEventsを定義する必要があります。

使えるイベントに制限があります

  Text
Box		 Check
Box		 Option
Button		 Combo
Box		 List
Box		 Command
Button
AfterUpdate × × × × × －
BeforeDragOver 〇 〇 〇 〇 〇 〇
BeforeDropOrPaste × × × × × ×
BeforeUpdate × × × × × －
Change 〇 〇 〇 〇 〇 －
Click － 〇 〇 〇 〇 〇
DblClick 〇 〇 〇 〇 〇 〇
DropButtonClick 〇 － － 〇 － －
Enter × × × × × ×
Exit × × × × × ×
KeyDown 〇 〇 〇 〇 〇 〇
KeyPress 〇 〇 〇 〇 〇 〇
KeyUp 〇 〇 〇 〇 〇 〇
MouseDown 〇 〇 〇 〇 〇 〇
MouseMove 〇 〇 〇 〇 〇 〇
MouseUp 〇 〇 〇 〇 〇 〇
〇：使用できます。
×：使用できません。
－：元々イベントが存在しません。
AfterUpdate
Enter
Exit
このあたりが使用できないところが厳しいところです。
例えば、
第16回.アクティブコントロールに色を付ける
ユーザーフォーム入門として基礎から解説します。フォーム内のどこにカーソルがあるか分かりづらい場合があります。そこで、アクティブなコントロールのバックカラーを変えたり、対応するラベルのフォントを変更したりして、アクティブなコントロールを解り易くします。
ここではEnterイベントを使っていますので、これは共通化できないことになります。

※これについては、何か良い方法がありそうにも思えます。
良い解決策が見つかったら、新たに記事を書きますね。
このように記載していました。

問題解決した経緯

最初に以下のツイートをみかけました
https://twitter.com/nukie_53/status/1215601274298621952?ref_src=twsrc%5Etfw
このツイートでリンクされている先は、
http://addinbox.sakura.ne.jp/Temp/EventHandling_C2CP.htm
AddinBoxという有名なサイトです。

調べていく過程で見つけたページ
https://br.ccm.net/faq/29419-gestao-dos-eventos-sair-e-entrar-da-caixa-de-texto-criados-dinamicamente

AddinBoxの中の人が教えてくれました
私のツイートをたどって前回の記事を読まれたようで、解決方法を教えてくれました。
教えていただいたリンクは、

「API:ConnectToConnectionPointによるイベント処理の構築」
http://addinbox.sakura.ne.jp/Bpca_Common.htm#C2CP

併せて熟読すると良い内容として、mougさんのアーカイブリンクも紹介して頂きました。

moug/VBAクラス研究室(1)～(5)
https://web.archive.org/web/20120911012129/http://moug.net/faq/viewtopic.php?t=62306
https://web.archive.org/web/20120911231242/http://moug.net/faq/viewtopic.php?t=62566
https://web.archive.org/web/20130115194304/http://moug.net/faq/viewtopic.php?t=62720
https://web.archive.org/web/20130514173245/http://moug.net/faq/viewtopic.php?t=64302
https://web.archive.org/web/20150322143040/http://moug.net/faq/viewtopic.php?t=68110
今回の件については、一番下の(5)がとても参考になります。

API:ConnectToConnectionPointについて

「ConnectToConnectionPoint function」
http://msdn.microsoft.com/en-us/library/windows/desktop/bb773794(v=vs.85).aspx

関連するMSDNのページもほとんどがアーカイブとなっているようで、詳細を調べるのはとても大変そうです。
詳細の解説はとてもできそうにないので、知りたい方はリンクを辿って各自で調べてみてください。

特にConnectToConnectionPointの挙動についてより詳しく確認したい場合は、
VBAクラス研究室(5)
https://web.archive.org/web/20150322143040/http://moug.net/faq/viewtopic.php?t=68110
この中の真ん中位に、
「…UserForm上すべてのTextBoxに対してイベントを接続させ、イベント名とConnectionPointContainer名（今回だと対象TextBox名）を列挙します。」
として、VBAの全コードが掲載されています。
32bit用のVBAとなっていますが、そのまま動かすことができます。
このVBAの内容を一つずつ調べていくと理解が進むと思いますが、
ただし、この全てを理解するのはとても大変だと思います・・・

ConnectToConnectionPointの使用例

実際にConnectToConnectionPointを使ってみました。
フォーム上の全てのコントロールについて、
フォーカスを受け取った時に背景色を変えて、フォーカスを失ったときに色を戻します。
使用例という事もあり、EnterイベントとExitイベントのペアでVBAを書きました。

クラスモジュール

クラスにAttributeを設定する必要があります。
詳細については、
VBAクラスのAttributeについて（既定メンバーとFor Each）
VBAクラスをエクスポートすると各種のAttributeが設定されているのが確認できます。それぞれのAttributeの意味と、さらに追加で指定できるAttributeについて説明します。Attributeの変更はVBA標準でサポートされておらず、その使用については慎重であるべきですが、どのようなものがあるかを知るのは、
こちらを参照してください。

インポートファイル：clsEvent.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsEvent"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'API定義 [ ConnectToConnectionPoint ]
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
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
Private Cookie As Long
Private MyCtrl As Object 'イベント接続するコントロール
'イベント接続
Public Property Set Control(NewCtrl As Object)
    Set MyCtrl = NewCtrl
    Call ConnectEvent(True)
End Property
'イベント切断
Public Sub Clear()
    If (Cookie <> 0) Then
        Call ConnectEvent(False)
    End If
    Set MyCtrl = Nothing
End Sub
'イベント接続切断
Private Sub ConnectEvent(ByVal Connect As Boolean)
    Dim IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    ConnectToConnectionPoint Me, IID_IDispatch, Connect, MyCtrl, Cookie, 0&
End Sub
'Enterイベントで背景色設定
Public Sub Event_Enter()
    Attribute Event_Enter.VB_UserMemId = -2147384830
    If TypeName(MyCtrl) = "Frame" Then Exit Sub
    MyCtrl.Tag = MyCtrl.BackColor
    MyCtrl.BackColor = RGB(255, 153, 204)
End Sub
'Exitイベントで背景色戻し
Public Sub Event_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Attribute Event_Exit.VB_UserMemId = -2147384829
    Dim ctl As Control
    If TypeName(MyCtrl) = "Frame" Then
        For Each ctl In MyCtrl.Controls
            If ctl.Tag <> "" Then ctl.BackColor = ctl.Tag
        Next
    Else
        MyCtrl.BackColor = MyCtrl.Tag
    End If
End Sub

Attribute Event_Enter.VB_UserMemId = -2147384830
Attribute Event_Exit.VB_UserMemId = -2147384829
この2行がそれぞれのイベントプロシージャーに対するID数値の設定になります。

Event_EnterやEvent_Exitのプロシージャー名は自由に変更して構いません。
引数とVB_UserMemIdだけは一致させてください。

インポート後のclsEvent
Option Explicit

'API定義 [ ConnectToConnectionPoint ]
Private Type GUID
　　Data1 As Long
　　Data2 As Integer
　　Data3 As Integer
　　Data4(0 To 7) As Byte
End Type
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
Private Cookie As Long

Private MyCtrl As Object 'イベント接続するコントロール

'イベント接続
Public Property Set Control(NewCtrl As Object)
　　Set MyCtrl = NewCtrl
　　Call ConnectEvent(True)
End Property

'イベント切断
Public Sub Clear()
　　If (Cookie <> 0) Then
　　　　Call ConnectEvent(False)
　　End If
　　Set MyCtrl = Nothing
End Sub

'イベント接続切断
Private Sub ConnectEvent(ByVal Connect As Boolean)
　　Dim IID_IDispatch As GUID
　　With IID_IDispatch
　　　　.Data1 = &H20400
　　　　.Data4(0) = &HC0
　　　　.Data4(7) = &H46
　　End With
　　ConnectToConnectionPoint Me, IID_IDispatch, Connect, MyCtrl, Cookie, 0&
End Sub

'Enterイベントで背景色設定
Public Sub Event_Enter()
　　If TypeName(MyCtrl) = "Frame" Then Exit Sub
　　MyCtrl.Tag = MyCtrl.BackColor
　　MyCtrl.BackColor = RGB(255, 153, 204)
End Sub

'Exitイベントで背景色戻し
Public Sub Event_Exit(ByVal Cancel As MSForms.ReturnBoolean)
　　Dim ctl As Control
　　If TypeName(MyCtrl) = "Frame" Then
　　　　For Each ctl In MyCtrl.Controls
　　　　　　If ctl.Tag <> "" Then ctl.BackColor = ctl.Tag
　　　　Next
　　Else
　　　　MyCtrl.BackColor = MyCtrl.Tag
　　End If
End Sub

フォームモジュール

モジュール名：何でも構いません

Option Explicit

'イベント補足クラスのコレクション
Private colEvent As New Collection

Private Sub UserForm_Initialize()
　　Dim clsEvent As clsEvent
　　Dim ctl As Control
　　For Each ctl In Me.Controls
　　　　Set clsEvent = New clsEvent
　　　　Set clsEvent.Control = ctl
　　　　colEvent.Add clsEvent
　　Next
End Sub

Private Sub UserForm_Terminate()
　　Dim clsEvent As clsEvent
　　Dim ctl As clsEvent
　　For Each ctl In colEvent
　　　　ctl.Clear
　　Next
　　Set colEvent = Nothing
End Sub


フォームを作成して、適当にいろいろなコントロールを配置し動作確認してください。
元の色はTagプロパティに保存するようにしています。
ここはやり方がいろいろありますが、Tagプロパティの使い方の紹介も兼ねてこのようにしてみました。

Frameについては、EnterとExitイベントの挙動が難しいものになります。
フレーム外に移った時、フレーム内の選択コントロールはフォーカスを失いません。
上記では、無理やり色を戻していますので、
フレーム内の先頭コントロールからフレーム外に移り、再度フレームに戻った時は先頭コントロールに色が付きません。
今回の趣旨から外れるのでVBAを複雑にしないために、この細部の挙動についての対応はしていません。
もし実際に使うのであれば、フレーム内の最終コントロールを別途保存しておくといった方法等をかんがえる必要があります。

イベントと対応するVB_UserMemIdの一覧とインポート用雛形

VB_UserMemIdの一覧

イベント 16進 10進
Change &H2 2
BeforeDragOver &H3 3
BeforeDropOrPaste &H4 4
Click &HFFFFFD9E -610
DblClick &HFFFFFDA7 -601
KeyDown &HFFFFFDA6 -602
KeyPress &HFFFFFDA5 -603
KeyUp &HFFFFFDA4 -604
MouseDown &HFFFFFDA3 -605
MouseMove &HFFFFFDA2 -606
MouseUp &HFFFFFDA1 -607
Error &HFFFFFDA0 -608
Exit &H80018203 -2147384829
Enter &H80018202 -2147384830
BeforeUpdate &H80018201 -2147384831
AfterUpdate &H80018200 -2147384832
DropButtonClick &H7D2 2002

クラスのインポート用雛形

イベント記載部分だけになります。

Private Sub Event_Enter()
    Attribute Event_Enter.VB_UserMemId = -2147384830
End Sub
Private Sub Event_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Attribute Event_Enter.VB_UserMemId = -2147384829
End Sub
Private Sub Event_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    Attribute Event_Enter.VB_UserMemId = -2147384831
End Sub
Private Sub Event_AfterUpdate()
    Attribute Event_Enter.VB_UserMemId = -2147384832
End Sub
Private Sub Event_Change()
    Attribute Event_Enter.VB_UserMemId = 2
End Sub
Private Sub Event_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
    Attribute Event_Enter.VB_UserMemId = 3
End Sub
Private Sub Event_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
    Attribute Event_Enter.VB_UserMemId = 4
End Sub
Private Sub Event_Click()
    Attribute Event_Enter.VB_UserMemId = -610
End Sub
Private Sub Event_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Attribute Event_Enter.VB_UserMemId = -601
End Sub
Private Sub Event_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Attribute Event_Enter.VB_UserMemId = -602
End Sub
Private Sub Event_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Attribute Event_Enter.VB_UserMemId = -603
End Sub
Private Sub Event_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Attribute Event_Enter.VB_UserMemId = -604
End Sub
Private Sub Event_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Attribute Event_Enter.VB_UserMemId = -605
End Sub
Private Sub Event_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Attribute Event_Enter.VB_UserMemId = -606
End Sub
Private Sub Event_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Attribute Event_Enter.VB_UserMemId = -607
End Sub
Private Sub Event_DropButtonClick()
    Attribute Event_Enter.VB_UserMemId = 2002
End Sub

イベントプロシージャーの共通化の最後に

前回も書きましたが、
クラスを使った難解なVBAになってしまうので、気軽に使うという類のものではないようにも思います。

よほど汎用的にコントロールを自在に扱う必要に迫られなければ使う事はないでしょう。
今回は、もし必要になった時の参考として、ここにまとめておきました。

むしろ実際に使うというより、イベントの動作への理解を深める教材としてとてもよいかもしれません。
ぜひ一度、実際に動かしてその挙動を確認してみてください。


同じテーマ「ユーザーフォーム入門」の記事

第17回.Enterキーで次のコントロールに移動する
第18回.２段階のコンボボックス
第19回.数値専用のテキストボックス
第20回.テキストボックスの各種イベント
第21回.ユーザーフォームの各種イベント
第22回.コントロールの動的作成
第23回.イベントプロシージャーの共通化
第24回.イベントプロシージャーの共通化（Enter,Exit）
第25回.簡易音楽プレーヤーの作成
第26回.プログレスバーを自作する
第27回.インクリメンタルサーチの実装


新着記事NEW ・・・新着記事一覧を見る

多階層フォルダ（ディレクトリ）の作成｜VBAサンプル集（7月31日）
VBAのインデントについて｜VBA技術解説（7月16日）
「VBA Match関数の限界」についての誤解｜エクセル雑感（7月15日）
省略可能なVariant引数の参照不可をラップ関数で利用｜VBA技術解説（7月12日）
100桁の正の整数値の足し算｜エクセル雑感（7月9日）
LSetとユーザー定義型のコピー（100桁の足し算）｜VBA技術解説（7月9日）
Variant仮引数のByRefとByValの挙動違い｜エクセル雑感（7月5日）
Variant仮引数にRange.Valueを配列で渡す方法｜エクセル雑感（7月5日）
Variantの数値型と文字列型の比較｜エクセル雑感（7月1日）
VBAのVariant型について｜VBA技術解説（6月30日）


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.マクロって何？VBAって何？｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
8.セルに文字を入れるとは（Range,Value）｜VBA入門
9.とにかく書いてみよう（Sub,End Sub）｜VBA入門
10.マクロはどこに書くの（VBEの起動）｜VBA入門



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク


↑