HOME > エクセルVBA > サンプル > TextBoxMenu

TextBoxMenu


【ファイル名】TextBoxMenu.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年06月23日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】TextBoxMenu.zip
【説明】ユーザーフォームのテキストボックスの右クリックでポップアップメニューを表示します。

画面

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="TextBoxMenu">
          <button id="ShowFormButton" label="フォームを表示" keytip="S" size="large" imageMso="HappyFace"
                  supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

clsTextBoxMenu
Option Explicit

#Const USESENDKEYS = False ' True にするとメソッドではなく、SendKeys を使います。(メソッドとは違い「元に戻す」、「やり直し」ができます)

Private WithEvents m_TextBox As MSForms.TextBox
Private WithEvents m_UserForm As MSForms.UserForm
Private WithEvents m_UndoBtn As Office.CommandBarButton
Private WithEvents m_RedoBtn As Office.CommandBarButton
Private WithEvents m_CutBtn As Office.CommandBarButton
Private WithEvents m_CopyBtn As Office.CommandBarButton
Private WithEvents m_PasteBtn As Office.CommandBarButton
Private WithEvents m_DeleteBtn As Office.CommandBarButton
Private WithEvents m_SelectAllBtn As Office.CommandBarButton

Public Sub Init(ByVal Value As MSForms.TextBox)
  Set m_TextBox = Value
  Set m_UserForm = Value.Parent
End Sub

Private Sub m_UndoBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' 元に戻す
'#If USESENDKEYS Then
'  SendKeys "^Z"
'#Else
  m_UserForm.UndoAction
'#End If
End Sub

Private Sub m_RedoBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' やり直し
'#If USESENDKEYS Then
'  SendKeys "^Y"
'#Else
  m_UserForm.RedoAction
'#End If
End Sub

Private Sub m_CutBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' 切り取り
#If USESENDKEYS Then
  SendKeys "^X"
#Else
  m_TextBox.Cut
#End If
End Sub

Private Sub m_CopyBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' コピー
#If USESENDKEYS Then
  SendKeys "^C"
#Else
  m_TextBox.Copy
#End If
End Sub

Private Sub m_PasteBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' 貼り付け
#If USESENDKEYS Then
  SendKeys "^V"
#Else
  m_TextBox.Paste
#End If
End Sub

Private Sub m_DeleteBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' 削除
#If USESENDKEYS Then
  SendKeys "{DELETE}"
#Else
  m_TextBox.SelText = ""
#End If
End Sub

Private Sub m_SelectAllBtn_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) ' すべて選択
#If USESENDKEYS Then
  SendKeys "^A"
#Else
  m_TextBox.SelStart = 0
  m_TextBox.SelLength = Len(m_TextBox.Text)
#End If
End Sub

' 右クリックの MouseDown イベントは2回連続して発生するので、MouseUp を使うこと!
Private Sub m_TextBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button <> xlSecondaryButton Then Exit Sub  ' 右クリックでなければ終了
  
  With Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True) ' ポップアップ メニューを表示する
    Set m_UndoBtn = .Controls.Add(msoControlButton)
    m_UndoBtn.Caption = "元に戻す(&U)"
    m_UndoBtn.Enabled = m_UserForm.CanUndo
    m_UndoBtn.FaceId = 128
    
    Set m_RedoBtn = .Controls.Add(msoControlButton)
    m_RedoBtn.Caption = "やり直し(&Y)"
    m_RedoBtn.Enabled = m_UserForm.CanRedo
    m_RedoBtn.FaceId = 129
    
    Set m_CutBtn = .Controls.Add(msoControlButton)
    m_CutBtn.Caption = "切り取り(&X)"
    m_CutBtn.Enabled = m_TextBox.SelLength > 0
    m_CutBtn.FaceId = 21
    m_CutBtn.BeginGroup = True
    
    Set m_CopyBtn = .Controls.Add(msoControlButton)
    m_CopyBtn.Caption = "コピー(&C)"
    m_CopyBtn.Enabled = m_TextBox.SelLength > 0
    m_CopyBtn.FaceId = 19
    
    Set m_PasteBtn = .Controls.Add(msoControlButton)
    m_PasteBtn.Caption = "貼り付け(&V)"
    m_PasteBtn.Enabled = m_TextBox.CanPaste
    m_PasteBtn.FaceId = 22
      
    Set m_DeleteBtn = .Controls.Add(msoControlButton)
    m_DeleteBtn.Caption = "削除(&D)"
    m_DeleteBtn.Enabled = m_TextBox.SelLength > 0
    m_DeleteBtn.FaceId = 67
    
    Set m_SelectAllBtn = .Controls.Add(msoControlButton)
    m_SelectAllBtn.Caption = "すべて選択(&A)"
    m_SelectAllBtn.Enabled = m_TextBox.TextLength > 0 And m_TextBox.TextLength <> m_TextBox.SelLength
    m_SelectAllBtn.BeginGroup = True
    
    .ShowPopup
    .Delete
  End With
End Sub
このページの上

UserForm1
Option Explicit

Private arrMenu() As clsTextBoxMenu

Private Sub UserForm_Initialize() ' 初期化
  Dim ctrl As MSForms.control
  Dim i As Long
  
  i = 0
  For Each ctrl In Controls
    If TypeOf ctrl Is MSForms.TextBox Then
      i = i + 1
      ReDim Preserve arrMenu(1 To i) As clsTextBoxMenu
      Set arrMenu(i) = New clsTextBoxMenu
      arrMenu(i).Init ctrl
    End If
  Next
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub
このページの上