Контекстное меню для TextBox на форме - MS Access - Ответ 13432075

Option Explicit
'--------------------------------------------------------------------------
' Module    : modTextBoxMenu
' Author    : vb001  ( + я чутка)
' Date      : 24.03.2019
' Purpose   : Контекстное меню для TextBox
'--------------------------------------------------------------------------
'   По материалам:
'   https://www.cyberforum.ru/ms-access/thread2423596-page2.html
'--------------------------------------------------------------------------
 
Private objTBox As Control
Public Sub BuildTextBoxMenu(objTextBox As Control)
'Построение временного меню ....
'--------------------------------------------------------------------------
Dim App As Application
Dim ObjCommandBar As Object  'Office.CommandBar
Dim ObjButton As Object 'Office.CommandBarButton
'--------------------------------------------------------------------------
On Error GoTo BuildTextBoxMenu_Err
    
 
    KillCustomMenuName "TextBoxMenu" 'удаляем если уже построено
    
    
    Set App = Application
    Set ObjCommandBar = App.CommandBars.Add("TextBoxMenu", 5, False, True) '5=msoBarPopup - Последний аргумент = временный
    
    Set objTBox = objTextBox
    
    
    With ObjCommandBar
        Set ObjButton = .Controls.Add(1, 128) '128=acCmdUndo
        With ObjButton
            .Caption = "Отменить (Undo)"
        End With
            
        Set ObjButton = .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 = .Controls.Add(1, 19) '19 = Copy
        With ObjButton
            .Caption = "Копировать (Copy)"
            If objTextBox.SelLength = 0 Then
                .Enabled = False
            End If
        End With
        
        Set ObjButton = .Controls.Add(1, 22) '22 = Paste
        With ObjButton
            .Caption = "Вставить (Paste)"
            'Если буфер обмена пустой ...
            If IsTextInClipboard = False Then
                .Enabled = False
            End If
        End With
        
        
        Set ObjButton = .Controls.Add(1, 478) '478 Delete
        With ObjButton
            .Caption = "Удалить (Delete)"
            '.FaceId = 1088 ???
            If objTextBox.SelLength = 0 Then
                .Enabled = False
            End If
 
        End With
        
        Set ObjButton = .Controls.Add(1, 1)
        With ObjButton
            .Caption = "Выделить всё!"
            .BeginGroup = True 'Разделитель
            .FaceId = 194
            .OnAction = "BuildTextBoxMenu_SelectAll"
        End With
        
        
    End With
'--------------------------------------------------------------------------
'Готово!
    objTextBox.ShortcutMenuBar = "TextBoxMenu"
 
BuildTextBoxMenu_End:
    On Error Resume Next
    Set ObjButton = Nothing
    Set ObjCommandBar = 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 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
Private Function IsTextInClipboard() As Boolean
'Проверка есть ли текст в буфере обмена ClipBoard
'--------------------------------------------------------------------------
Dim sText As String
Dim cbObject As Object
'--------------------------------------------------------------------------
On Error GoTo IsTextInClipboard_Err
    
    Set cbObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    cbObject.GetFromClipboard
    sText = cbObject.GetText
    'Debug.Print sText
    sText = Trim(sText)
    If Len(sText) > 0 Then
        IsTextInClipboard = True
    End If
 
IsTextInClipboard_End:
    On Error Resume Next
    Set cbObject = Nothing
    Err.Clear
    Exit Function
 
IsTextInClipboard_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: IsTextInClipboard in module: 00_Tests", vbCritical, "Error in Application"
    Err.Clear
    Resume IsTextInClipboard_End
End Function