Caixa de texto do Userform com menu de contexto (botão direito do mouse)

Olá amigos.
Continuando o artigo onde respondo ao leitor Alexandro, concluo agora a resposta às suas perguntas. Veja a pergunta enviada para nós:

Saudações, quando criei um formulário no Excel (usando VBA),
os usuários reclamaram bastante dele, pois não se tem os botões
maximizar, minimizar, não se pode usar o botão do meio do mouse (rolagem para cima e para baixo),
além de não podê-lo redimensioná-lo verticalmente, em diagonal ou horizontalmente, além
de num textbox ou combobox não se pode clicar com botão direito com uma opção para colar algo
da área de transferência (daí deve-se usar control + V).
Tem alguma propriedade de formulário que faz isso ?
Como estes detalhes podem ser feitos em um formulário do EXCEL VBA ?
Obrigado Obrigado Obrigado

Então, caríssimos leitores, o menu de contexto que é o responsável por essa solicitação do Alexandro. Esse menu é chamado com o clique do botão direito do mouse. E, infelizmente, o userform pura e simplesmente não tem suporte nativo para esta funcionalidade.
Para responder esta questão, encontrei uma alternativa implementada no site www.andypope.info e vou adaptá-la neste artigo. Vejam como ficou.
Vamos adicionar uma classe que tratará de incluir um menu de contexto dentro do controle textbox acionado pleo clique do botão direito do mouse. Esta classe acessa algumas propriedades do menu do aplicativo.
Crie um módulo de classe com o nome “CTextBox_ContextMenu”. Veja seu código:

Option Explicit
'<<<<                 Créditos                      >>>>>'
'** http://www.andypope.info/vba/uf_contextualmenu.htm **'
'........................................................'
Private Const mEDIT_CONTEXTMENU_NAME = "ajpiEditContextMenu"
Private Const mCUT_TAG = "Recortar"
Private Const mCOPY_TAG = "Copiar"
Private Const mPASTE_TAG = "Colar"
Private m_cbrContextMenu As CommandBar
Private WithEvents m_txtTBox As MSForms.TextBox
Private WithEvents m_cbtCut As CommandBarButton
Private WithEvents m_cbtCopy As CommandBarButton
Private WithEvents m_cbtPaste As CommandBarButton
Private m_objDataObject As DataObject
Private m_objParent As Object
Private Function m_CreateEditContextMenu() As CommandBar
'
' Build Context menu controls.
'
    Dim cbrTemp As CommandBar
    Const CUT_MENUID = 21
    Const COPY_MENUID = 19
    Const PASTE_MENUID = 22
    Set cbrTemp = Application.CommandBars.Add(mEDIT_CONTEXTMENU_NAME, Position:=msoBarPopup)
    With cbrTemp
        With .Controls.Add(msoControlButton)
            .Caption = "&Recortar"
            .FaceId = CUT_MENUID
            .Tag = mCUT_TAG
        End With
        With .Controls.Add(msoControlButton)
            .Caption = "&Copiar"
            .FaceId = COPY_MENUID
            .Tag = mCOPY_TAG
        End With
        With .Controls.Add(msoControlButton)
            .Caption = "C&olar"
            .FaceId = PASTE_MENUID
            .Tag = mPASTE_TAG
        End With
    End With
    Set m_CreateEditContextMenu = cbrTemp
End Function
Private Sub m_DestroyEditContextMenu()
    On Error Resume Next
    Application.CommandBars(mEDIT_CONTEXTMENU_NAME).Delete
    Exit Sub
End Sub
Private Function m_GetEditContextMenu() As CommandBar
    On Error Resume Next
    Set m_GetEditContextMenu = Application.CommandBars(mEDIT_CONTEXTMENU_NAME)
    If m_GetEditContextMenu Is Nothing Then
        Set m_GetEditContextMenu = m_CreateEditContextMenu
    End If
    Exit Function
End Function
Private Function m_ActiveTextbox() As Boolean
'
' Make sure this instance is connected to active control
' May need to drill down through container controls to
' reach ActiveControl object
'
    Dim objCtl As Object
    Set objCtl = m_objParent.ActiveControl
    Do While UCase(TypeName(objCtl)) <> "TEXTBOX"
        If UCase(TypeName(objCtl)) = "MULTIPAGE" Then
            Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl
        Else
            Set objCtl = objCtl.ActiveControl
        End If
    Loop
    m_ActiveTextbox = (StrComp(objCtl.Name, m_txtTBox.Name, vbTextCompare) = 0)
ErrActivetextbox:
    Exit Function
End Function
Public Property Set Parent(RHS As Object)
    Set m_objParent = RHS
End Property
Private Sub m_UseMenu()
    Dim lngIndex As Long
    For lngIndex = 1 To m_cbrContextMenu.Controls.Count
        Select Case m_cbrContextMenu.Controls(lngIndex).Tag
        Case mCUT_TAG
            Set m_cbtCut = m_cbrContextMenu.Controls(lngIndex)
        Case mCOPY_TAG
            Set m_cbtCopy = m_cbrContextMenu.Controls(lngIndex)
        Case mPASTE_TAG
            Set m_cbtPaste = m_cbrContextMenu.Controls(lngIndex)
        End Select
    Next
End Sub
Public Property Set TBox(RHS As MSForms.TextBox)
    Set m_txtTBox = RHS
End Property
Private Sub Class_Initialize()
    Set m_objDataObject = New DataObject
    Set m_cbrContextMenu = m_GetEditContextMenu
    If Not m_cbrContextMenu Is Nothing Then
        m_UseMenu
    End If
End Sub
Private Sub Class_Terminate()
    Set m_objDataObject = Nothing
    m_DestroyEditContextMenu
End Sub
Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    ' check active textbox is this instance of CTextBox_ContextMenu
    If m_ActiveTextbox() Then
        With m_objDataObject
            .Clear
            .SetText m_txtTBox.SelText
            .PutInClipboard
        End With
    End If
End Sub
Private Sub m_cbtCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    ' check active textbox is this instance of CTextBox_ContextMenu
    If m_ActiveTextbox() Then
        With m_objDataObject
            .Clear
            .SetText m_txtTBox.SelText
            .PutInClipboard
            m_txtTBox.SelText = vbNullString
        End With
    End If
End Sub
Private Sub m_cbtPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    ' check active textbox is this instance of CTextBox_ContextMenu
    On Error GoTo ErrPaste
    If m_ActiveTextbox() Then
        With m_objDataObject
            .GetFromClipboard
            m_txtTBox.SelText = .GetText
        End With
    End If
ErrPaste:
    Exit Sub
End Sub
Private Sub m_txtTBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        ' right click
        m_cbrContextMenu.ShowPopup
    End If
End Sub

Agora, o código do UserForm1, contendo dois controles textbox (Textbox1 e Textbox2):

Option Explicit
Private m_colContextMenus As Collection
Private clsContextMenu As CTextBox_ContextMenu
Private Sub UserForm_Initialize()
On Error GoTo ErroVBA
 'Define o menu de contexto
 Call DefineMenuDeContexto
Erro_Exit:
 Exit Sub
ErroVBA:
 MsgBox Err.Description
 Exit Sub
End Sub
Private Sub DefineMenuDeContexto()
 Set m_colContextMenus = New Collection
 'TextBox1
 Set clsContextMenu = New CTextBox_ContextMenu
 With clsContextMenu
 Set .TBox = Me.TextBox1
 Set .Parent = Me
 End With
 m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
 'TextBox2
 Set clsContextMenu = New CTextBox_ContextMenu
 With clsContextMenu
 Set .TBox = Me.TextBox2
 Set .Parent = Me
 End With
 m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 Set m_colContextMenus = Nothing
 Set clsContextMenu = Nothing
End Sub

Agora experimente clicar com o botão direito dentro da caixa de texto. Será exibido uma lista com as opções:

  • Recortar;
  • Copiar;
  • Colar.

Então é isso pessoal,
Um abraço.

4 Responses

Leave a Comment