ExcelVBA技 ユーザーフォーム E13U014

E13U014 (Excel2000~2013)
ユーザーフォームのテキストボックスにコピー&貼り付け等の右クリックショトカットメニューを付加する

ユーザーフォームのテキストボックスにコピー&貼り付け等の右クリックショトカットメニューを付加するクラス[CRightClick] をご紹介します。
対応コントロール:[テキストボックス]、[コンボボックス]
メニュー項目  :[切り取り]、[コピー]、[貼り付け]、[削除]、[すべて選択]
使い方は非常に簡単で、CRightClickクラスのインスタンスを作成し Initializeメソッドを呼ぶだけです。

'フォーム モジュール
Option Explicit

'クラスモジュール CRightClick の使用例
Private Sub UserForm_Initialize()
  Static dcp As New CRightClick
  dcp.Initialize Me
End Sub
'CRightClick クラスモジュール
Option Explicit
Public WithEvents Tb As MSForms.TextBox
Public WithEvents Cb As MSForms.ComboBox
Private WithEvents BCut  As Office.CommandBarButton
Private WithEvents BCopy As Office.CommandBarButton
Private WithEvents BPaste As Office.CommandBarButton
Private WithEvents BDelete As Office.CommandBarButton
Private WithEvents BAll As Office.CommandBarButton
Dim dbox As Collection

Private Sub BAll_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  Dim bx As Object
  If TypeName(Tb) = "TextBox" Then Set bx = Tb Else Set bx = Cb
  With bx
    .SelStart = 0
    .SelLength = Len(.Value)
  End With
End Sub
Private Sub BCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.Copy Else Cb.Copy
End Sub
Private Sub BCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.Cut Else Cb.Cut
End Sub
Private Sub BDelete_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.SelText = "" Else Cb.SelText = ""
End Sub
Private Sub BPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.Paste Else Cb.Paste
End Sub

Private Sub Cb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
  ByVal X As Single, ByVal Y As Single)
  If Button = 2 And Cb.Style = fmStyleDropDownCombo Then pCopyPaste Cb
End Sub
Private Sub Tb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
  ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then pCopyPaste Tb
End Sub

Sub Initialize(fm As Object)
  Dim cc As CRightClick, bx As Object
  On Error Resume Next
  Set dbox = New Collection
  For Each bx In fm.Controls
    Select Case TypeName(bx)
    Case "TextBox", "ComboBox"
      Set cc = New CRightClick
      If TypeName(bx) = "TextBox" Then Set cc.Tb = bx Else Set cc.Cb = bx
      dbox.Add cc
    End Select
  Next
End Sub
Private Sub pCopyPaste(bx As Object) 'Copy&Paste右クリックメニュー
  With Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    Set BCut = .Controls.Add(msoControlButton)
    With BCut
      .Caption = "切り取り(&T)"
      .FaceId = 21
      .Enabled = bx.SelLength
      If bx.Locked Then .Enabled = False
    End With
    Set BCopy = .Controls.Add(msoControlButton)
    With BCopy
      .Caption = "コピー(&C)"
      .FaceId = 19
      .Enabled = bx.SelLength
    End With
    Set BPaste = .Controls.Add(msoControlButton)
    With BPaste
      .Caption = "貼り付け(&P)"
      .FaceId = 22
      .Enabled = bx.CanPaste
    End With
    Set BDelete = .Controls.Add(msoControlButton)
    With BDelete
      .Caption = "削除(&D)"
      .FaceId = 47
      .Enabled = bx.SelLength
      .BeginGroup = True
    End With
    Set BAll = .Controls.Add(msoControlButton)
    With BAll
      .Caption = "すべて選択(&A)"
      .Enabled = Len(bx.Value)
    End With
    .ShowPopup
    .Delete
  End With
End Sub