LoginSignup
4
6

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

@towa_skm

VBAでMSFormsのラッパークラスを作る

Posted at

概要

MSFormsのラッパークラスを作った、ついでにイベント処理をコールバックで実装できる。

経緯

  1. VBAでフォームを作るときに素のMSFormsのままだと地味に使いにくい。
  2. ラッパークラスを作ろう！
  3. イベント処理をコールバックで処理するのもできるようになった。

フォーム上にある具体的なコントロールであるLabel1などにはNameプロパティがあるが、
MSForms.Label型の変数だとNameプロパティはなく、Nameを候補に出すにはMSForms.Control型に入れる必要がある。
動的にフォームを作る場合にそんな感じで個別の型とControlを使い分けるのは面倒。
なのでImplementsを使ってIControlインタフェースを作りつつ、個別のクラスのラッパーを用意すればそのあたりを意識せずに使用できるのではと作ったもの。

共通となるIControlインタフェース用のクラス

IControl.cls
Option Explicit
Public Enum EventTypeEnum
    evClick
    evChange
End Enum
Public Function Init(ByVal MSControl_ As MSForms.Control) As IControl:End Function
Public Function Move(Optional ByVal Left_ As Variant, Optional ByVal Top_ As Variant, Optional ByVal Width_ As Variant, Optional ByVal Height_ As Variant = Null) As IControl:End Function
Public Function GetName() As String:End Function
Public Function GetValue() As Variant:End Function
Public Function SetCaption(ByVal Text_ As String) As IControl:End Function
Public Function SetBackColor(ByVal Color_ As Long) As IControl:End Function
Public Function GetHeight() As Double:End Function
Public Function GetTop() As Double:End Function
Public Function GetLeft() As Double:End Function
Public Function GetWidth() As Double:End Function
Public Function GetRight() As Double:End Function
Public Function SetRight(ByVal RightEnd_ As Double) As IControl:End Function
Public Function GetBottom() As Double:End Function
Public Function SetCallBack(ByVal CallBack_ As IFormCallBack, ByVal EventType_ As EventTypeEnum) As IControl: End Function

共通としてほしいプロパティをペアで用意する。
今回は後で使うサンプルを動かすの必要なものだけを用意。
せっかくなのでメソッドチェーンを使えるようにプロパティではなくGetとSetのメソッドで実装。
プロパティと違ってメソッドであれば取得の型と設定の型を一致させなくてもいいので設定時には型で拘束できるメリットもある。
サンプルにはあまりないがインタフェースのGetの型にはVariantがそこそこ出てくる。
例えばValueは文字、数値、真偽値など返す値の種類が定まっていない。
FontSizeはDoubleで良さそうだがSpinButtonには存在しないので0を返すことになるが、ないという事をエラーとしてわかりやすくNullを返すようにする場合はDoubleではなくVariantにする必要がある。

個別のクラスのサンプル(Label)

MyLabel.cls
Option Explicit
Implements IControl 'インタフェースを関連付ける
Private WithEvents MyControl As MSForms.Label '本体はWithEventsで捕まえておく
Private ClickCallBack As IFormCallBack '伝えるイベント別のコールバッククラスを入れる変数
Private ClickFlag As Boolean 'イベントを多重実行させないようにするためのフラグ、TextBoxのChangeなどで特に重要
Public Event Click(ByVal MyLabel_ As MyLabel) 'コールバックではなくラッパークラスをWithEventsで捕まえて使用する場合用のEvent

'コントロールのイベントでリレーまたはコールバック処理を行う
Private Sub MyControl_Click()
    If Not ClickFlag Then
        ClickFlag = True
        If ClickCallBack Is Nothing Then
            RaiseEvent Click(Me)
        Else
            Call ClickCallBack.Execute(Me, evClick)
        End If
        ClickFlag = False
    End If
End Sub

Rem 初期化は個別のクラスには要らないのでインタフェース側だけ用意する
Private Function IControl_Init(ByVal MSControl_ As MSForms.Control) As IControl
    Set IControl_Init = Me
    Select Case True
        Case MSControl_ Is Nothing
            Err.Raise 1, TypeName(Me), "コントロールを渡してください"
        Case TypeOf MSControl_ Is MSForms.Label
            Set MyControl = MSControl_
        Case Else
            Err.Raise 1, TypeName(Me), "ラベル以外のコントロールが渡されています"
    End Select
End Function

'イベント別の変数にコールバッククラスを入れる
Private Function IControl_SetCallBack(ByVal CallBack_ As IFormCallBack, ByVal EventType_ As EventTypeEnum) As IControl
    Select Case EventType_
        Case evClick: Set ClickCallBack = CallBack_
    End Select
End Function

Public Function GetName() As String
    GetName = MyControl.Name '候補に出ないだけで呼び出すことはできる
End Function
Private Function IControl_GetName() As String
    IControl_GetName = Me.GetName 'インタフェース側は表に出しているものをそのまま渡すだけ
End Function

'RightやBottomは元々はないが相対位置で置くときにあると便利
Public Function GetRight() As Double
    GetRight = MyControl.Left + MyControl.Width
End Function
Public Function SetRight(ByVal Right_ As Double) As MyLabel
    Set SetRight = Me
    MyControl.Left = Right_ - MyControl.Width
End Function

'特定のコントロールだけのやつはインタフェース無しで実装する
Public Function GetSpecialEffect() As MSForms.fmSpecialEffect
    GetSpecialEffect = MyControl.SpecialEffect
End Function
Public Function SetSpecialEffect(ByVal Enum_ As MSForms.fmSpecialEffect) As MyLabel
    Set SetSpecialEffect = Me
    MyControl.SpecialEffect = Enum_
End Function

'LabelにValueは存在しないがLabelのValue相当のものを渡すことで他のものとまとめて扱えるようになる
Private Function IControl_GetValue() As Variant
    IControl_GetValue = MyControl.Caption
End Function

'Moveは省略と実際に渡した場合を区別できるようにするのでVariantを使っている
Private Function IControl_Move(Optional ByVal Left_ As Variant, _
                                Optional ByVal Top_ As Variant, _
                                Optional ByVal Width_ As Variant, _
                                Optional ByVal Height_ As Variant = Null) As IControl
    Set IControl_Move = Me
    If IsNumeric(Left_) And Not IsMissing(Left_) Then MyControl.Left = Left_
    If IsNumeric(Top_) And Not IsMissing(Top_) Then MyControl.Top = Top_
    If IsNumeric(Width_) And Not IsMissing(Width_) Then MyControl.Width = Width_
    If IsNumeric(Height_) Then MyControl.Height = Height_
End Function
'以下インタフェースと実際の処理を実装するが今回は省略。

LabelのGetValueでCaptionを取れるようにするなどするとLabelとTextBoxをまとめてGetValueで値を持ってくるというようなことができるようになるので便利。
SetValue(ByVal Value_ As Variant)のようにインタフェース側で引数がVariantになっているものは個別の方で型を指定する場合はインタフェース側から入ったときに型でエラーを起こさないように分岐させたりOn Error Resume Nextでごまかしが必要。
MoveはIsMissingとIsNumericで値を調べて実装する。
IsNumericだけだとEmptyで通ってしまうが省略した場合にNullを渡すようにすればIsNumericだけで済む。
ただしVBEの上のプルダウンから追加する場合はインタフェース側でNullを設定していても反映されないので手直しが必要。

Sample.clsとImplementsSample.cls
'インタフェース側
Public Function Sample(ByVal Argument_ As Variant = Null) As Variant: End Function
'Implementsしたクラスでプルダウンメニューから追加したときの値
Private Function Sample_Sample(ByVal Argument_ As Variant = Empty) As Variant: End Function

ラベルの拡張

MyLabel.cls
    Public Event Change(ByVal MyLabel_ As MyLabel)
    Private LabelValue As String
    Private CaptionArray(1 To 3) As String
    Public Function GetValue() As String
        GetValue = LabelValue
    End Function
    Public Function SetValue(ByVal Value_ As String) As MyLabel
        CaptionArray(2) = Value_
        MyControl.Caption = Join(CaptionArray, "")
        RaiseEvent Change(Me)
    End Function
    Public Function SetPrefix(ByVal Prefix_ As String) As MyLabel
        Set SetPrefix = Me
        CaptionArray(1) = Prefix
    End Function
    Public Function SetSuffix(ByVal Suffix_ As String) As MyLabel
        Set SetSuffix = Me
        CaptionArray(3) = Suffix_
    End Function

ラベルのValueをCaptionとイコールにせずに、内部で値を持たせるようにして単位や接頭辞を付けられるようにする。
ここでRaiseEvent Change(Me)などとして、本来は存在しないLabelのChangeイベントを作ってもいい。
これがあれば例えばAutoSizeが有効な場合にLabelのCaptionが変わると大きさが変わるのでそれを検知してFrameのスクロール範囲を調整するといった処理もできるようになる。
ただしラッパークラスを介さずに操作されると検知できないので処理方法は統一すること。

コールバック処理の実装

VBAでコールバック関数を実装を参考にして、クラスとインタフェースを使って実装。
今回はフォーム専用のコールバッククラスなので、インタフェースの引数にはイベントの発生元のコントロールラッパーとイベントの種類、他に追加の引数を渡す。
SubではなくFunctionにしているのはByRefを使って値を返すタイプのものもあったはずなのでそれを処理する結果を返せるようにするため。
必要に応じてExecuteの結果をラッパー側でいい感じに処理させる。

IFormCallBack.cls
Option Explicit
Public Function Execute(ByVal IControl_ As IControl, ByVal EventType_ As EventTypeEnum, ParamArray Arguments_() As Variant) As Varint
End Sub
CallBackClickMessage.cls
Option Explicit
Implements IFormCallBack
Private Function IFormCallBack_Execute(ByVal IControl_ As IControl, ByVal EventType_ As EventTypeEnum, ParamArray Arguments_() As Variant) As Variant
    Select Case EventType_
        Case evClick: Call MsgBox(IControl_.GetValue) 'クリックイベントが起こったら対象のValueをMsgBoxで表示する
    End Select
End Sub

実際のコールバックの中身であるIFormCallBack_Executeはどのコントロールがどのイベントを起こしたかを区別できるので、一つのコールバックの中にClickとChangeの処理を書いてSetCallBackで違うイベントに同じコールバックを渡して処理させることもできる。
クラスを複数使って役割を分けるか、クラスが増えるとVBEは醜くなるのでコールバックを集約するかはお好みで。
IControlのGetNameやTypeOfで区別させれば一つのフォームのすべてのイベントを一つのコールバック用クラスで管理することも可能。
コールバック用のインタフェースを持っていればいいので見た目部分を作成するための処理やフォームを管理するクラスにImplementsさせてごちゃごちゃとまとめることもできる。
その場合は他のコントロールに干渉する処理を書きやすくなるが一つのクラスが肥大化していく。

使い方のサンプル

Module1.bas
Option Explicit
Sub Sample()
    Dim MyForm As UserForm1
    Set MyForm = New UserForm1
    Dim MSLabel1 As MSForms.Label
    Set MSLabel2 = MyForm.Controls.Add("Forms.Label.1","SampleLabel1")
    Dim CallBack As IFormCallBack
    Set CallBack = New CallBackClickMessage
    Dim MyLabel1 As MyLabel, MyLabel2 As MyLabel
    Set MyLabel1 = CIControl(New MyLabel) _
                    .Init(MSLabel1) _
                    .SetCaption("表示したい文字") _
                    .SetCallBack(CallBack, evClick) _
                    .Move(5, 10, 100, 30) _
                    .SetBackColor(vbRed)
    Dim MSLabel2 As MSForms.Label
    Set MSLabel2 = MyForm.Controls.Add("Forms.Label.1","SampleLabel2")
    With MyLabel1
        Set MyLabel2 = CIControl(New MyLabel) _
                        .Init(MSLabel2) _
                        .SetCaption("ふたつめ") _
                        .SetCallBack(CallBack, evClick) _
                        .Move(.GetRight, .GetBottom, .GetWidth, .GetHeight) _
                        .SetBackColor(vbBlue)
    End With
    MyForm.Show vbModal
End Sub
'型変換用
Public Function CIControl(ByVal IControl_ As IControl) As IControl
    Set CIControl = IControl_        
End Function
Public Function CMyLabel(ByVal IControl_ As IControl) As MyLabel
    Set CMyLabel = IControl_
End Function

ラッパーに使用しているメソッドが実装してあれば
ラッパーを作ってそこに実際のフォーム上のLabelを渡して設定を行ってフォームを表示する。
左上あたりに赤いラベルとその右下に青いラベルが作られる。
どちらのラベルにも個別の処理は書いていないが、クリックするとSetCallBackで渡したCallBackClickMessageクラスによってメッセージボックスが表示される。

Dim Dic As Scripting.Dictionary
Set Dic = New Scripting.Dictionary
Dic.Add TempIControl.GetName, TempIcontrol

ラッパークラスのインスタンスはMyLabel1とMyLabel2という個別の変数にしなくても一旦適当な変数に置いてからScripting.Dictionaryでまとめて管理するのが楽。

4
6
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
4
6

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?