Меню (временное) для TextBox

http://www.cyberforum.ru/ms-access/thread2423596-page2.html

В форме:

Private Sub txtTest_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then 'Если нажата правая кнопка мыши (Right = 2) - выводим меню:
        BuildTextBoxMenu Me!txtTest
    End If
End Sub

Модуль:

'--------------------------------------------------------------------------
' Module    : modTextBoxMenu
' Author    : es
' Date      : 18.04.2019
' Purpose   : Контекcтное меню для TextBox
'--------------------------------------------------------------------------
'   По материалам:
'   http://www.cyberforum.ru/ms-access/thread2423596-page2.html
'--------------------------------------------------------------------------
Private objTBox As Control
Public Sub BuildTextBoxMenu(objTextBox As Control)
'Построение временного меню ....
'--------------------------------------------------------------------------
Dim App As Application
Dim ObjCB As Object   'Office.CommandBar ''
Dim ObjSubCB As Object  'Office.CommandBar
Dim ObjButton As Object 'Office.CommandBarButton
Dim s$
'--------------------------------------------------------------------------
On Error GoTo BuildTextBoxMenu_Err
    

    KillCustomMenuName "TextBoxMenu" 'удаляем если уже построено
    
    
    Set App = Application
    Set ObjCB = App.CommandBars.Add("TextBoxMenu", 5, False, True) '5=msoBarPopup - Последний аргумент = временный
    
    Set objTBox = objTextBox
    
    

    Set ObjButton = ObjCB.Controls.Add(1, 128) '128=acCmdUndo
    With ObjButton
        .Caption = "Отменить (Undo)"
    End With
        
    Set ObjButton = ObjCB.Controls.Add(1, 21) '21 = Cut
    With ObjButton
        .Caption = "Вырезать (Cut)"
        .BeginGroup = True
        If objTextBox.SelLength = 0 Then
            .Enabled = False
        End If
    End With
            
    Set ObjButton = ObjCB.Controls.Add(1, 19) '19 = Copy
    With ObjButton
        .Caption = "Копировать (Copy)"
        If objTextBox.SelLength = 0 Then
            .Enabled = False
        End If
    End With
    
    Set ObjButton = ObjCB.Controls.Add(1, 22) '22 = Paste
    With ObjButton
        .Caption = "Вставить (Paste)"
        s = GetClipboard
        'Debug.Print Len(s)
        If Len(s) = 0 Then
            .Enabled = False
        End If
    End With


'--------------------------------------------------------------------------
'Подменю!!!!
    Set ObjSubCB = ObjCB.Controls.Add(10) '10 = msoControlPopup
    ObjSubCB.Caption = "Вставить из шаблона ..."
    ObjSubCB.BeginGroup = True 'Разделитель
    
    Set ObjButton = ObjSubCB.Controls.Add(1, 22) '22 = Paste
    With ObjButton
        ' Change the caption displayed for the control.
        .Caption = "Вставить из шаблона 01"
        .OnAction = "=IncertFromTemplate(1)"
    End With
    
    Set ObjButton = ObjSubCB.Controls.Add(1, 22) '22 = Paste
    With ObjButton
        ' Change the caption displayed for the control.
        .Caption = "Вставить из шаблона 02"
        .OnAction = "=IncertFromTemplate(2)"
    End With
    
    Set ObjButton = ObjSubCB.Controls.Add(1, 22) '22 = Paste
    With ObjButton
        ' Change the caption displayed for the control.
        .Caption = "Вставить из шаблона 03"
        .OnAction = "=IncertFromTemplate(3)"
    End With
    
'--------------------------------------------------------------------------
    
    
    
    Set ObjButton = ObjCB.Controls.Add(1, 478) '478 Delete
    With ObjButton
        .BeginGroup = True 'Разделитель
        .Caption = "Удалить (Delete)"
        '.FaceId = 1088 ???
        If objTextBox.SelLength = 0 Then
            .Enabled = False
        End If

    End With
    
    Set ObjButton = ObjCB.Controls.Add(1, 1)
    With ObjButton
        .Caption = "Выделить всё!"
        .BeginGroup = True 'Разделитель
        .FaceId = 194
        .OnAction = "BuildTextBoxMenu_SelectAll"
    End With



'--------------------------------------------------------------------------
'Готово!
    objTextBox.ShortcutMenuBar = "TextBoxMenu"

BuildTextBoxMenu_End:
    On Error Resume Next
    Set ObjButton = Nothing
    Set ObjCB = Nothing
    Set App = Nothing
    Err.Clear
    Exit Sub

BuildTextBoxMenu_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Sub: BuildTextBoxMenu in module: modTextBoxMenu", vbCritical, "Error in Application"
    Err.Clear
    Resume BuildTextBoxMenu_End
    
End Sub
Public Function IncertFromTemplate(i%)
Dim s$, iStart%, iLen%, sOld$, sNew$
    iStart = objTBox.SelStart
    iLen = objTBox.SelLength
    sOld = objTBox.Text
    Select Case i
        Case 1
            s = "Шаблон 001"
        Case 2
            s = "Шаблон 002"
        Case 3
            s = "Шаблон 003"
    End Select
    'SetClipboard s можно и так ... а потом вставка ...

    sNew = Mid(sOld, 1, iStart) & s & Mid(sOld, iStart + iLen + 1)
    objTBox.Text = sNew
    objTBox.SelStart = iStart
    objTBox.SelLength = Len(s)
    
End Function


Public Function BuildTextBoxMenu_SelectAll()
    objTBox.SetFocus
    objTBox.SelStart = 0
    objTBox.SelLength = Len(objTBox.Text)
End Function
Private Sub KillCustomMenuName(sName$)
' Удаление меню с заданным названием
'--------------------------------------------------------------------------
Dim App As Application
On Error GoTo KillCustomMenu_Err
    
    Set App = Application
    App.CommandBars(sName).Delete
    

KillCustomMenu_End:
    On Error Resume Next
    Set App = Nothing
    Err.Clear
    Exit Sub

KillCustomMenu_Err:
    'MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Sub: KillCustomMenu in module: modUtilities", vbCritical, "Error in Application"
    Err.Clear
    Resume KillCustomMenu_End
End Sub

MSA-2007 ( 48 kB) Пример