1. Add a new userform called Userform1
2. Add a textbox called TextBox1
3. Paste the following into the userform's code module:
1. Add a new userfor m
'------------------------------------------------
Option Explicit
Private Const strRIGHTCLICKMENU_NAME As String = "MyRightClickMenu"
Private Sub UserForm_Initialize()
CreateRightClickMenu
End Sub
Private Sub UserForm_Terminate()
KillRightClickMenu
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As
Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
Excel.Application.CommandBars(strRIGHTCLICKMENU_NAME).ShowPopup
End If
End Sub
Private Function CreateRightClickMenu() As Boolean
On Error Resume Next
Excel.Application.CommandBars(strRIGHTCLICKMENU_NAME).Delete
On Error GoTo 0
With CommandBars.Add(strRIGHTCLICKMENU_NAME, msoBarPopup)
With .Controls.Add(msoControlButton)
.Caption = "Cut"
.FaceId = 21
.OnAction = "MenuCut"
End With
With .Controls.Add(msoControlButton)
.Caption = "Copy"
.FaceId = 19
.OnAction = "MenuCopy"
End With
With .Controls.Add(msoControlButton)
.Caption = "Paste"
.FaceId = 22
.OnAction = "MenuPaste"
End With
End With
CreateRightClickMenu = True
End Function
Private Sub KillRightClickMenu()
On Error Resume Next
Excel.Application.CommandBars(strRIGHTCLICKMENU_NAME).Delete
On Error GoTo 0
End Sub
'------------------------------------------------
4. Add a standard module and paste in the following code:
'------------------------------------------------
Option Explicit
Public Sub MenuCut()
Dim strTextToAdd As String
Dim DataObject1 As DataObject
Dim ctlActive As MSForms.Control
On Error GoTo Err_Handler
If UserForm1.Visible = False Then
Unload UserForm1
Exit Sub
End If
Set DataObject1 = New DataObject
Set ctlActive = UserForm1.ActiveControl
Do Until Not TypeOf ctlActive Is MSForms.Frame
Set ctlActive = ctlActive.ActiveControl
Loop
strTextToAdd = ctlActive.SelText
If Len(strTextToAdd) > 0 Then
With DataObject1
.SetText strTextToAdd
.PutInClipboard
End With
ctlActive.SelText = vbNullString
End If
Err_Handler:
Set DataObject1 = Nothing
End Sub
Public Sub MenuCopy()
Dim strTextToAdd As String
Dim DataObject1 As DataObject
Dim ctlActive As MSForms.Control
On Error GoTo Err_Handler
If UserForm1.Visible = False Then
Unload UserForm1
Exit Sub
End If
Set DataObject1 = New DataObject
Set ctlActive = UserForm1.ActiveControl
Do Until Not TypeOf ctlActive Is MSForms.Frame
Set ctlActive = ctlActive.ActiveControl
Loop
strTextToAdd = ctlActive.SelText
If Len(strTextToAdd) > 0 Then
With DataObject1
.SetText strTextToAdd
.PutInClipboard
End With
End If
Err_Handler:
Set DataObject1 = Nothing
End Sub
Public Sub MenuPaste()
Dim strTextToAdd As String
Dim DataObject1 As DataObject
Dim ctlActive As MSForms.Control
On Error GoTo Err_Handler
If UserForm1.Visible = False Then
Unload UserForm1
Exit Sub
End If
Set DataObject1 = New DataObject
DataObject1.GetFromClipboard
strTextToAdd = DataObject1.GetText()
If Len(strTextToAdd) > 0 Then
Set ctlActive = UserForm1.ActiveControl
Do Until Not TypeOf ctlActive Is MSForms.Frame
Set ctlActive = ctlActive.ActiveControl
Loop
ctlActive.SelText = strTextToAdd
End If
Err_Handler:
Set DataObject1 = Nothing
End Sub
'------------------------------------------------
5. Run the userform, type some text in the textbox, right click and
try out the menu items.
