VBAのユーザーフォームはVisualBasicと違い、コントロールを配列にできない欠点があります。
VB.NETで同様のサンプルを作成しました。
「コントロールの配列化サンプル」です。
同じように「日付」「金額」のテキストボックスを3個ずつならべたもので、フォーカスインとフォーカスアウトでの編集動作だけを行なうものです。
最初から6個のテキストボックスをテーブル化させて、それぞれのイベントは共通記述にさせていますので VBA(ユーザーフォーム)との動作や記述の違いなどをぜひご覧下さい。
同じように「日付」「金額」のテキストボックスを3個ずつならべたもので、フォーカスインとフォーカスアウトでの編集動作だけを行なうものです。
最初から6個のテキストボックスをテーブル化させて、それぞれのイベントは共通記述にさせていますので VBA(ユーザーフォーム)との動作や記述の違いなどをぜひご覧下さい。
クラスで処理すると配列として処理し、クラス内で共通にイベント記述させることができます。
これは、昔、MOUGのサイトで大村あつし先生が「スキルアップ講座」で書いておられたサンプルを見て作ったものです。
(画像をクリックすると、このサンプルがダウンロードできます)
クリックイベントをクラスモジュール側でトラップしてしまうものです。私のオリジナリティには欠けるのでここでは詳しい説明は省きます。
クラスの利用は、「API関連」のページでも別な形で登場します。本当はここでテキストボックスをセル書式のように編集する前項の例をクラス処理で実現したかったのですが、テキストボックス(MSForms.TextBox)をクラス化しても「Enter」や「Exit」のイベントはトラップできません。
「Click」「KeyDown」「MouseDown」等はトラップできますが、コントロールからのフォーカス脱出が掴めないので片手落ちです。
共通なチェック処理や編集表示を作成するにしても「Exit」イベントで行ないたいですし、こうなるとクラス処理する必然性が半減してしまいます。前項の「数値入力や日付入力の工夫」など同種の入力項目が複数ある時に集約できる方式として期待したのですが正攻法では無理なようです。
ならばと調べた(過去のMLのログなど)のですが、方法は「ない」こともないようです。実行動作は前ページの「数値入力や日付入力の工夫」と同じです。
(画像をクリックすると、このサンプルがダウンロードできます)
どう処理するのかと言うと、「クラス側でイベントを掴む」のではなく「クラス側でイベントを発生させる」のです。
まず、イベントクラスモジュール(clsExitFocus)のソースコードです。
'***************************************************************************************************
' フォーム上のコントロールの配列利用のためのクラス clsExitFocus(Class)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/07/18(1.00)新規作成
'19/10/24(1.01)*.xlsm化、他
'20/02/24(1.10)記述修正(標準化準拠含む)、オブジェクト最適化
'***************************************************************************************************
Option Explicit
'===================================================================================================
#If VBA7 Then
' ■スリープ(API)
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
#Else
' ■スリープ(API)
Private Declare Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
#End If
'---------------------------------------------------------------------------------------------------
Private g_strActCont As String ' 現在のコントロール名
Private g_blnActCont As Boolean ' 現在のコントロールはTextBoxか
Private g_objActCont As MSForms.TextBox ' 現在のコントロール(TextBox)
'===================================================================================================
' 発生させるTextBoxのEnter独自イベント
Public Event EnterFocus(lngIx As Long)
' 発生させるTextBoxのExit独自イベント
Public Event ExitFocus(lngIx As Long)
'***************************************************************************************************
' ■■■ イベント監視 ■■■
'***************************************************************************************************
'* 処理名 ：ActConrol
'* 機能 ：フォーム上でActiveControlが移動するのを監視
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = ユーザーフォーム(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：引数はMsForms.UserFormではダメ！(プロパティにTagがない)
'***************************************************************************************************
Public Sub ActControl(objForm As UserForm1)
'-----------------------------------------------------------------------------------------------
' 実行時エラーでは本ループは強制的に停止
On Error GoTo ActControl_Exit
With objForm
' このループはUserFormの表示中繰り返す
Do
DoEvents
' UserFormのTagにてループ中止を判断
If .Tag = 9 Then Exit Do
' コントロールのフォーカスが変わったことの判定
If .ActiveControl.Name <> g_strActCont Then
' 直前のコントロールがTextBoxか
If g_blnActCont Then
' Exitイベントを発生させる
RaiseEvent ExitFocus(CLng(g_objActCont.Tag))
End If
' 現在フォーカスのコントロール名を取得
g_strActCont = .ActiveControl.Name
' 現在フォーカスのコントロールはTextBoxか
If TypeName(.ActiveControl) = "TextBox" Then
' 現在フォーカスのコントロールを取得
g_blnActCont = True
Set g_objActCont = .ActiveControl
' Enterイベントを発生させる
RaiseEvent EnterFocus(CLng(g_objActCont.Tag))
Else
g_blnActCont = False
End If
End If
' Sleep(20ms：CPU負荷軽減のため)
Sleep 20
Loop
End With
'===================================================================================================
' 終了(エラートラップ含む)
ActControl_Exit:
' Terminateでおそらくエラーとなって抜けている
On Error GoTo 0
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
このクラスはユーザーフォームの起動時に「WithEvents」で呼び出され、ユーザーフォームが開いている間常駐します。
このクラスには「EnterFocus」「ExitFocus」という独自イベントが用意されています。
ユーザーフォームの「UserForm_Activate」内で「ActControl」プロシージャが呼び出されます。
「ActControl」プロシージャ内はユーザーフォームの終了までの無限ループが配置されており、20ms間隔で繰り返します。 ループ内で「ActiveControl」の変更を監視しており、変更があった時にはまず、 以前のTextBoxに対して「ExitFocus」イベントを発生させて、 新しい「ActiveControl」がTextBoxであれば「EnterFocus」を発生させるという動作をするものです。
これでユーザーフォーム側の記述はテキストボックスのコントロールの数に関係なく、一対の「EnterFocus」「ExitFocus」のイベント記述だけで済みます。
それではユーザーフォーム側のソースコードですが、記述順に沿ってまずはモジュール宣言部分とフォームイベントです。
'***************************************************************************************************
' サンプルユーザーフォーム UserForm1(Class)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/07/18(1.00)新規作成
'19/10/24(1.01)*.xlsm化、他
'20/02/24(1.10)記述修正(標準化準拠含む)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsDate As String = "YYYY/MM/DD"
Private Const g_cnsDateE As String = "YYYY/M/D"
'---------------------------------------------------------------------------------------------------
Private WithEvents clsForm As clsExitFocus ' 独自クラス
Private g_tblType(5) As Integer ' 動作タイプ(0=日付、1=金額)
Private g_objTextBox(5) As MSForms.TextBox ' TextBox
'***************************************************************************************************
' ■■■ フォームイベント ■■■
'***************************************************************************************************
'* 処理名 ：UserForm_Activate
'* 機能 ：フォーム初期表示
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Activate()
'-----------------------------------------------------------------------------------------------
Me.Tag = 0
' clsForm.ActConrolを起動する(停止されるまでループ)
clsForm.ActControl Me
End Sub
'***************************************************************************************************
'* 処理名 ：UserForm_Initialize
'* 機能 ：フォーム初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Initialize()
'-----------------------------------------------------------------------------------------------
' 動作タイプ(0=日付、1=金額)の指定
g_tblType(0) = 0 ' TXT_DATE1
g_tblType(1) = 1 ' TXT_GAKU1
g_tblType(2) = 0 ' TXT_DATE2
g_tblType(3) = 1 ' TXT_GAKU2
g_tblType(4) = 0 ' TXT_DATE3
g_tblType(5) = 1 ' TXT_GAKU3
' クラスインスタンスを生成
Set clsForm = New clsExitFocus
' テキストボックスを配列として取得しておく
Set g_objTextBox(0) = TXT_DATE1
Set g_objTextBox(1) = TXT_GAKU1
Set g_objTextBox(2) = TXT_DATE2
Set g_objTextBox(3) = TXT_GAKU2
Set g_objTextBox(4) = TXT_DATE3
Set g_objTextBox(5) = TXT_GAKU3
' 初期クリア
Call GP_ClearForm
End Sub
'***************************************************************************************************
'* 処理名 ：UserForm_QueryClose
'* 機能 ：フォーム閉鎖動作
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'-----------------------------------------------------------------------------------------------
' イベント生成処理を停止指示(Hideする前に必須)
Me.Tag = 9
End Sub
'***************************************************************************************************
'* 処理名 ：UserForm_Terminate
'* 機能 ：フォーム閉鎖
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Terminate()
'-----------------------------------------------------------------------------------------------
' クラスインスタンスを廃棄
Set clsForm = Nothing
End Sub
今回、このような「クドイ」記述になってしまったのは、配列保持したテキストボックスに対して動的に「Enter」「Exit」のイベントがトラップできないというところから始まっています。
そこでこの「Enter」「Exit」を代替するクラスを作成して、そのクラス側から独自イベントを発生させるという処理になっています。
次はその「代替イベント」の部分です。
'***************************************************************************************************
' ■■■ コントロールイベント ■■■
'***************************************************************************************************
'* 処理名 ：clsForm_EnterFocus
'* 機能 ：テキストボックスのEnter代替イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = テキストボックスのINDEX(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub clsForm_EnterFocus(lngIx As Long)
'-----------------------------------------------------------------------------------------------
' 金額か
If g_tblType(lngIx) = 1 Then
' 金額項目入力用編集
Call GP_GakuEnter(g_objTextBox(lngIx))
Else
' 日付項目入力用編集
Call GP_DateEnter(g_objTextBox(lngIx))
End If
End Sub
'***************************************************************************************************
'* 処理名 ：clsForm_ExitFocus
'* 機能 ：テキストボックスのExit代替イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = テキストボックスのINDEX(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub clsForm_ExitFocus(lngIx As Long)
'-----------------------------------------------------------------------------------------------
Dim blnRet As Boolean ' 処理結果
' 金額か
If g_tblType(lngIx) = 1 Then
' 金額項目表示用編集
blnRet = FP_GakuExit(g_objTextBox(lngIx))
Else
' 日付項目表示用編集
blnRet = FP_DateExit(g_objTextBox(lngIx))
End If
' エラー時はフォーカスを戻す(ここは配列処理不可？)
If Not blnRet Then
Select Case lngIx
Case 0: TXT_DATE1.SetFocus
Case 1: TXT_GAKU1.SetFocus
Case 2: TXT_DATE2.SetFocus
Case 3: TXT_GAKU2.SetFocus
Case 4: TXT_DATE3.SetFocus
Case 5: TXT_GAKU3.SetFocus
End Select
End If
End Sub
'***************************************************************************************************
'* 処理名 ：CMD_OK_Click
'* 機能 ：｢OK｣ボタンClickイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月18日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CMD_OK_Click()
'-----------------------------------------------------------------------------------------------
' イベント生成処理を停止指示(Hideする前に必須)
Me.Tag = 9
' フォームを非表示にする
Me.Hide
MsgBox TXT_DATE1.Text & vbCr & _
TXT_GAKU1.Text & vbCr & _
TXT_DATE2.Text & vbCr & _
TXT_GAKU2.Text & vbCr & _
TXT_DATE3.Text & vbCr & _
TXT_GAKU3.Text
End Sub
「clsForm_ExitFocus」も同様の説明になります。
この時「どのテキストボックスか」は引数でインデックスが渡されてくるので、これで判断すれば良いわけです。
後は共通のサブ処理ですが、内容は前ページと同じです。
'***************************************************************************************************
' ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名 ：GP_ClearForm
'* 機能 ：フォームクリア
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月25日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_ClearForm()
'-----------------------------------------------------------------------------------------------
Dim strDate As String ' 日付編集値
Dim strGaku As String ' 金額編集値
strDate = Format(Date, g_cnsDate)
strGaku = "0"
' 各テキストボックスに初期値をセット
TXT_DATE1.Text = strDate
TXT_GAKU1.Text = strGaku
TXT_DATE2.Text = strDate
TXT_GAKU2.Text = strGaku
TXT_DATE3.Text = strDate
TXT_GAKU3.Text = strGaku
End Sub
'***************************************************************************************************
'* 処理名 ：GP_DateEnter
'* 機能 ：日付項目入力用編集
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = テキストボックス(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月25日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_DateEnter(objTextBox As MSForms.TextBox)
'-----------------------------------------------------------------------------------------------
Dim strDate As String ' 入力テキスト
Dim dteDate As Date ' 日付値
strDate = Trim(objTextBox.Text)
' 日付なら月日の前ゼロを取る
If IsDate(strDate) Then
dteDate = CDate(strDate)
objTextBox.Text = Format(dteDate, g_cnsDateE)
' 全桁選択
Call GP_AllSelect(objTextBox)
End If
End Sub
'***************************************************************************************************
'* 処理名 ：FP_DateExit
'* 機能 ：日付項目表示用編集
'---------------------------------------------------------------------------------------------------
'* 返り値 ：チェック成否(Boolean)
'* 引数 ：Arg1 = テキストボックス(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月25日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_DateExit(objTextBox As MSForms.TextBox) As Boolean
'-----------------------------------------------------------------------------------------------
Dim strDate As String ' 入力テキスト
Dim dteDate As Date ' 日付値
FP_DateExit = False
strDate = Trim(objTextBox.Text)
' 日付なら再編集
If IsDate(strDate) Then
dteDate = CDate(strDate)
objTextBox.Text = Format(dteDate, g_cnsDate)
FP_DateExit = True
Else
MsgBox "日付ではありません。", vbExclamation
' 全桁選択
Call GP_AllSelect(objTextBox)
End If
End Function
'***************************************************************************************************
'* 処理名 ：GP_GakuEnter
'* 機能 ：金額項目入力用編集
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = テキストボックス(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月25日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_GakuEnter(objTextBox As MSForms.TextBox)
'-----------------------------------------------------------------------------------------------
Dim strGaku As String ' 入力テキスト
Dim crnGaku As Currency ' 金額値
strGaku = Trim(objTextBox.Text)
' 数値か
If IsNumeric(strGaku) Then
crnGaku = CCur(strGaku)
' 3桁カンマ除去で編集
objTextBox.Text = Format(crnGaku, "0")
' 全桁選択
Call GP_AllSelect(objTextBox)
End If
End Sub
'***************************************************************************************************
'* 処理名 ：FP_GakuExit
'* 機能 ：金額項目表示用編集
'---------------------------------------------------------------------------------------------------
'* 返り値 ：チェック成否(Boolean)
'* 引数 ：Arg1 = テキストボックス(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月25日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GakuExit(objTextBox As MSForms.TextBox) As Boolean
'-----------------------------------------------------------------------------------------------
Dim strGaku As String ' 入力テキスト
Dim crnGaku As Currency ' 金額値
FP_GakuExit = False
strGaku = Trim(objTextBox.Text)
' 数値か
If IsNumeric(strGaku) Then
crnGaku = CCur(strGaku)
' 3桁カンマ付きで編集
objTextBox.Text = Format(crnGaku, "#,##0")
FP_GakuExit = True
Else
MsgBox "数字ではありません。", vbExclamation
' 全桁選択
Call GP_AllSelect(objTextBox)
End If
End Function
'***************************************************************************************************
'* 処理名 ：GP_AllSelect
'* 機能 ：全桁選択
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = テキストボックス(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2003年07月25日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月24日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_AllSelect(objTextBox As MSForms.TextBox)
'-----------------------------------------------------------------------------------------------
With objTextBox
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
'----------------------------------------<< End of Source >>----------------------------------------