Skip to content

Commit 227bbd2

Browse files
vbatoolsvbatools
committed
Add context menu
Add context menu
1 parent bb0ee05 commit 227bbd2

File tree

4 files changed

+307
-0
lines changed

4 files changed

+307
-0
lines changed

‎UF_ContextualMenu.xlsm

34.9 KB
Binary file not shown.

‎scripts/CTextBox_ContextMenu.cls

Lines changed: 208 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,208 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "CTextBox_ContextMenu"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
11+
'* Module : CTextBox_ContextMenu
12+
'* Created : 11-04-2021 11:00
13+
'* Author : VBATools
14+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
15+
'* Copyright : VBATools.ru
16+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
17+
Option Explicit
18+
19+
Private Const mEDIT_CONTEXTMENU_NAME = "ajpiEditContextMenu"
20+
Private Const mCUT_TAG = "CUT"
21+
Private Const mCOPY_TAG = "COPY"
22+
Private Const mPASTE_TAG = "PASTE"
23+
24+
Private m_cbrContextMenu As CommandBar
25+
Private WithEvents m_txtTBox As msforms.TextBox
26+
Attribute m_txtTBox.VB_VarHelpID = -1
27+
Private WithEvents m_cbtCut As CommandBarButton
28+
Attribute m_cbtCut.VB_VarHelpID = -1
29+
Private WithEvents m_cbtCopy As CommandBarButton
30+
Attribute m_cbtCopy.VB_VarHelpID = -1
31+
Private WithEvents m_cbtPaste As CommandBarButton
32+
Attribute m_cbtPaste.VB_VarHelpID = -1
33+
Private m_objDataObject As DataObject
34+
Private m_objParent As Object
35+
36+
37+
38+
Private Function m_CreateEditContextMenu() As CommandBar
39+
'
40+
' Build Context menu controls.
41+
'
42+
Dim cbrTemp As CommandBar
43+
Const CUT_MENUID = 21
44+
Const COPY_MENUID = 19
45+
Const PASTE_MENUID = 22
46+
47+
Set cbrTemp = Application.CommandBars.Add(mEDIT_CONTEXTMENU_NAME, Position:=msoBarPopup)
48+
With cbrTemp
49+
With .Controls.Add(msoControlButton)
50+
.Caption = "Cu&t"
51+
.FaceId = CUT_MENUID
52+
.Tag = mCUT_TAG
53+
End With
54+
With .Controls.Add(msoControlButton)
55+
.Caption = "&Copy"
56+
.FaceId = COPY_MENUID
57+
.Tag = mCOPY_TAG
58+
End With
59+
With .Controls.Add(msoControlButton)
60+
.Caption = "&Paste"
61+
.FaceId = PASTE_MENUID
62+
.Tag = mPASTE_TAG
63+
End With
64+
End With
65+
66+
Set m_CreateEditContextMenu = cbrTemp
67+
68+
End Function
69+
Private Sub m_DestroyEditContextMenu()
70+
On Error Resume Next
71+
Application.CommandBars(mEDIT_CONTEXTMENU_NAME).Delete
72+
Exit Sub
73+
End Sub
74+
Private Function m_GetEditContextMenu() As CommandBar
75+
76+
On Error Resume Next
77+
78+
Set m_GetEditContextMenu = Application.CommandBars(mEDIT_CONTEXTMENU_NAME)
79+
If m_GetEditContextMenu Is Nothing Then
80+
Set m_GetEditContextMenu = m_CreateEditContextMenu
81+
End If
82+
83+
Exit Function
84+
85+
End Function
86+
87+
Private Function m_ActiveTextbox() As Boolean
88+
'
89+
' Make sure this instance is connected to active control
90+
' May need to drill down through container controls to
91+
' reach ActiveControl object
92+
'
93+
Dim objCtl As Object
94+
95+
Set objCtl = m_objParent.ActiveControl
96+
Do While UCase(TypeName(objCtl)) <> "TEXTBOX"
97+
If UCase(TypeName(objCtl)) = "MULTIPAGE" Then
98+
Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl
99+
Else
100+
Set objCtl = objCtl.ActiveControl
101+
End If
102+
Loop
103+
m_ActiveTextbox = (StrComp(objCtl.Name, m_txtTBox.Name, vbTextCompare) = 0)
104+
105+
ErrActivetextbox:
106+
Exit Function
107+
108+
End Function
109+
110+
Public Property Set Parent(RHS As Object)
111+
Set m_objParent = RHS
112+
End Property
113+
114+
Private Sub m_UseMenu()
115+
116+
Dim lngIndex As Long
117+
118+
For lngIndex = 1 To m_cbrContextMenu.Controls.Count
119+
Select Case m_cbrContextMenu.Controls(lngIndex).Tag
120+
Case mCUT_TAG
121+
Set m_cbtCut = m_cbrContextMenu.Controls(lngIndex)
122+
Case mCOPY_TAG
123+
Set m_cbtCopy = m_cbrContextMenu.Controls(lngIndex)
124+
Case mPASTE_TAG
125+
Set m_cbtPaste = m_cbrContextMenu.Controls(lngIndex)
126+
End Select
127+
Next
128+
129+
End Sub
130+
Public Property Set TBox(RHS As msforms.TextBox)
131+
Set m_txtTBox = RHS
132+
End Property
133+
134+
135+
Private Sub Class_Initialize()
136+
137+
Set m_objDataObject = New DataObject
138+
Set m_cbrContextMenu = m_GetEditContextMenu
139+
140+
If Not m_cbrContextMenu Is Nothing Then
141+
m_UseMenu
142+
End If
143+
144+
End Sub
145+
146+
Private Sub Class_Terminate()
147+
148+
Set m_objDataObject = Nothing
149+
m_DestroyEditContextMenu
150+
151+
End Sub
152+
153+
154+
Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
155+
156+
' check active textbox is this instance of CTextBox_ContextMenu
157+
If m_ActiveTextbox() Then
158+
With m_objDataObject
159+
.Clear
160+
.SetText m_txtTBox.SelText
161+
.PutInClipboard
162+
End With
163+
End If
164+
165+
End Sub
166+
167+
Private Sub m_cbtCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
168+
169+
' check active textbox is this instance of CTextBox_ContextMenu
170+
If m_ActiveTextbox() Then
171+
With m_objDataObject
172+
.Clear
173+
.SetText m_txtTBox.SelText
174+
.PutInClipboard
175+
m_txtTBox.SelText = vbNullString
176+
End With
177+
End If
178+
179+
End Sub
180+
181+
182+
Private Sub m_cbtPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
183+
184+
' check active textbox is this instance of CTextBox_ContextMenu
185+
On Error GoTo ErrPaste
186+
187+
If m_ActiveTextbox() Then
188+
With m_objDataObject
189+
.GetFromClipboard
190+
m_txtTBox.SelText = .GetText
191+
End With
192+
End If
193+
194+
ErrPaste:
195+
Exit Sub
196+
End Sub
197+
198+
199+
Private Sub m_txtTBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
200+
201+
If Button = 2 Then
202+
' right click
203+
m_cbrContextMenu.ShowPopup
204+
End If
205+
206+
End Sub
207+
208+

‎scripts/Module1.bas

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
Attribute VB_Name = "Module1"
2+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3+
'* Module : Module1
4+
'* Created : 11-04-2021 11:00
5+
'* Author : VBATools
6+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
7+
'* Copyright : VBATools.ru
8+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
9+
Option Explicit
10+
11+
Sub Main()
12+
13+
UserForm1.Show
14+
15+
End Sub

‎scripts/UserForm1.frm

Lines changed: 84 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,84 @@
1+
VERSION 5.00
2+
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm1
3+
Caption = "Textbox Contextual Menus"
4+
ClientHeight = 6180
5+
ClientLeft = 45
6+
ClientTop = 390
7+
ClientWidth = 5790
8+
OleObjectBlob = "UserForm1.frx":0000
9+
ShowModal = 0 'False
10+
StartUpPosition = 1 'CenterOwner
11+
End
12+
Attribute VB_Name = "UserForm1"
13+
Attribute VB_GlobalNameSpace = False
14+
Attribute VB_Creatable = False
15+
Attribute VB_PredeclaredId = True
16+
Attribute VB_Exposed = False
17+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
18+
'* Module : UserForm1
19+
'* Created : 11-04-2021 11:00
20+
'* Author : VBATools
21+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
22+
'* Copyright : VBATools.ru
23+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
24+
Option Explicit
25+
26+
Private m_colContextMenus As Collection
27+
28+
Private Sub CommandButton1_Click()
29+
Unload Me
30+
End Sub
31+
32+
Private Sub UserForm_Initialize()
33+
34+
Dim clsContextMenu As CTextBox_ContextMenu
35+
36+
Set m_colContextMenus = New Collection
37+
38+
Set clsContextMenu = New CTextBox_ContextMenu
39+
With clsContextMenu
40+
Set .TBox = UserForm1.TextBox1
41+
Set .Parent = Me
42+
End With
43+
m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
44+
45+
Set clsContextMenu = New CTextBox_ContextMenu
46+
With clsContextMenu
47+
Set .TBox = UserForm1.TextBox2
48+
Set .Parent = Me
49+
End With
50+
m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
51+
52+
Set clsContextMenu = New CTextBox_ContextMenu
53+
With clsContextMenu
54+
Set .TBox = UserForm1.TextBox3
55+
Set .Parent = Me
56+
End With
57+
m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
58+
59+
Set clsContextMenu = New CTextBox_ContextMenu
60+
With clsContextMenu
61+
Set .TBox = UserForm1.TextBox4
62+
Set .Parent = Me
63+
End With
64+
m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
65+
66+
Set clsContextMenu = New CTextBox_ContextMenu
67+
With clsContextMenu
68+
Set .TBox = UserForm1.TextBox5
69+
Set .Parent = Me
70+
End With
71+
m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
72+
73+
End Sub
74+
75+
Private Sub UserForm_Terminate()
76+
77+
Do While m_colContextMenus.Count > 0
78+
m_colContextMenus.Remove m_colContextMenus.Count
79+
Loop
80+
Set m_colContextMenus = Nothing
81+
82+
End Sub
83+
84+

0 commit comments

Comments
 (0)