[ListBox]右クリックでコンテキストメニューを表示する

リストボックスを右クリックしたときに、状況に応じたコンテキストメニューが表示されたら便利ですよね？

今回はそのようなコンテキストメニューを表示する方法を紹介します。

なお、この手法はリストボックス以外でも使えますので、あらゆる場面で活用できます。

MouseDownイベントハンドラ

右クリックすると、リストボックスのMouseDownイベントハンドラが発動します。

このとき、Button引数には右クリックであることを表す「2」が渡されますので、「2」以外ならExitします。

また、リストボックスに1行もデータが表示されていない場合は表示しない等の表示条件があれば、イベントハンドラの先頭でチェックしてExitするようにします。

Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If (Me.ListBox1.ListCount = 0) Then
        '1行も表示されていない場合はExit
        Exit Sub
    End If
    
    If (Button <> 2) Then
        '右クリック以外はExit
        Exit Sub
    End If

End Sub

コンテキストメニューの表示方法

    Dim cb As CommandBar
    Set cb = CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    With cb.Controls.Add
        .Caption = "メニュー1"
        .OnAction = "NonParamMethod"
        .Faceid = 455
    End With
    cb.ShowPopup

まず、CommandBarオブジェクトを生成します。このときに、Position:=msoBarPopupを指定するのがポイントです。

Temporary:=Trueは恒久的に表示するのではなく、一時的であることを表します。

次に、CommandBarオブジェクトのControlsプロパティに対してAddメソッドを実行します。

引数を省略してAddした場合は、サブメニューを持たない通常のメニューとなります。サブメニューを持つメニューの作り方はこのあとで説明します。

Addメソッドは、CommandBarControlオブジェクトを返却します。ここではCommandBarControl型の変数は宣言せずにWithで使い捨てています。

設定する各プロパティの意味は下記のとおりです。

プロパティ	設定内容
Caption	メニューに表示される文言
OnAction	クリック時に呼び出されるプロシジャー名
FaceId	表示されるアイコンのID（不要なら省略可）
BeginGroup	デフォルトはFalse。Trueを設定するとメニューの上に区切り線が表示されます（不要なら省略可）

OnActionの書き方

引数がある場合は、シングルクォーテーションで囲む必要があります。

.OnAction = "'ParamMethod(1)'"

引数がない場合でも、引数があるとき同様にシングルクォーテーションで囲んでも問題ありません。ただし、()を付けてはいけません。

.OnAction = "'ParamMethod'"
'''.OnAction = "'ParamMethod()'" '←これはNG。実行時に呼出エラーとなる

サブメニューの追加方法

サブメニューを表示するには、親メニューをAddするときにType:=msoControlPopupを指定します。

このとき、OnAction、FaceIdは指定してはいけません。指定するとエラーとなります。

次に、追加したCommandBarControlのControlsプロパティに対して、Addメソッドでサブメニューを追加します。

これは、サブメニューを持たないメニューを追加する方法とまったく同じです。

    Dim cbc As CommandBarControl
    Set cbc = cb.Controls.Add(Type:=msoControlPopup)
    cbc.Caption = "メニュー２"
    With cbc.Controls.Add
        .Caption = "メニュー２－１"
        .OnAction = "'NonParamMethod21'"
        .Faceid = 456
    End With
    With cbc.Controls.Add
        .Caption = "メニュー２－２"
        .OnAction = "'NonParamMethod22'"
        .Faceid = 457
    End With
    cb.ShowPopup

領域判定

リストボックスを右クリックしてコンテキストメニューを表示直後、リストボックス外を右クリックするとコンテキストメニューが表示されてしまいます。

これを防ぐには、MouseDownイベントはX, Y 引数がリストボックスの領域内にあるかどうかを調べ、領域外であれば無視するようにします。（X,Yにはマウスがクリックされたリストボックス内の座標が渡されます。）

    If (X < 0 Or X > Me.ListBox1.Width) Or (Y < 0 Or Y > Me.ListBox1.Height) Then
        'MsgBox "OutRange"
        Exit Sub
    End If

コンテキストメニュークラス

以上をふまえてコンテキストメニューを作ってみます。

基本に忠実に書くと下記のようになるでしょう。

    Dim cb As CommandBar
    Set cb = CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    With cb.Controls.Add
        .Caption = "test1"
        .OnAction = "Sub1"
        .Faceid = 410
    End With
    With cb.Controls.Add
        .Caption = "test2"
        .OnAction = "Sub2"
        .Faceid = 420
    End With
    Dim cbc As CommandBarControl
    Set cbc = cb.Controls.Add(Type:=msoControlPopup)
    cbc.Caption = "test3"
    With cbc.Controls.Add
        .Caption = "test3-1"
        .OnAction = "Sub31"
        .Faceid = 431
    End With
    With cbc.Controls.Add
        .Caption = "test3-2"
        .OnAction = "Sub32"
        .Faceid = 432
    End With
    With cbc.Controls.Add
        .Caption = "test3-3"
        .OnAction = "Sub33"
        .Faceid = 433
    End With
    Set cbc = cb.Controls.Add(Type:=msoControlPopup)
    cbc.Caption = "test4"
    With cbc.Controls.Add
        .Caption = "test4-1"
        .OnAction = "Sub41"
        .Faceid = 441
    End With
    With cbc.Controls.Add
        .Caption = "test4-2"
        .OnAction = "Sub42"
        .Faceid = 442
    End With
    With cbc.Controls.Add
        .Caption = "test4-3"
        .OnAction = "Sub43"
        .Faceid = 443
    End With
    cb.ShowPopup

可読性が悪く、冗長な感じがしますよね？

そこで、コンテキストメニューをすっきり記述できるクラスを作成してみました。

Option Explicit

Private cb_ As CommandBar
Private cbp_ As CommandBarPopup

Private Sub Class_Initialize()
    Set cb_ = CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
End Sub

Private Sub Class_Terminate()
    Set cb_ = Nothing
End Sub

Public Sub Add(Caption As String, OnAction As String, Optional Faceid As Long = 0)

    Dim cbc As CommandBarControl
    
    Set cbc = cb_.Controls.Add
    With cbc
        .Caption = Caption
        .OnAction = "'" & OnAction & "'"
        .Faceid = Faceid
    End With
    
    Set cbp_ = Nothing

End Sub

Public Sub AddMenu(Caption As String)

    Dim cbc As CommandBarControl
    
    Set cbc = cb_.Controls.Add(Type:=msoControlPopup)
    With cbc
        .Caption = Caption
    End With
    
    Set cbp_ = cbc

End Sub

Public Sub AddSubMenu(Caption As String, OnAction As String, Optional Faceid As Long = 0)

    If (cbp_ Is Nothing) Then
        MsgBox "サブメニューは、AddMenuメソッドで親メニューを作成した直後のみ追加できます。", vbExclamation, "ConetextMenu"
        Exit Sub
    End If
    
    Dim cbc As CommandBarControl
    Set cbc = cbp_.Controls.Add
    With cbc
        .Caption = Caption
        .OnAction = "'" & OnAction & "'"
        .Faceid = Faceid
    End With

End Sub

Public Sub ShowPopup()
    cb_.ShowPopup
End Sub

上記を「ContextMenu」クラスとして保存します。

そうすると…

先ほどの長くて可読性の悪かったソースはこのとおりスッキリします。

    With New ContextMenu
        .Add "test1", "Sub1", 456
        .Add "test2", "Sub2", 457
        .AddMenu "test3"
        .AddSubMenu "test3-1", "Sub31", 446
        .AddSubMenu "test3-2", "Sub32", 447
        .AddSubMenu "test3-3", "Sub33", 448
        .AddMenu "test4"
        .AddSubMenu "test4-1", "Sub41", 436
        .AddSubMenu "test4-2", "Sub42", 437
        .AddSubMenu "test4-3", "Sub43", 438
        .ShowPopup
    End With