1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
Option Explicit
' Required API declarations
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Type required by TrackPopupMenu although this is ignored !!
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Type required by InsertMenuItem
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
' Type required by GetCursorPos
Private Type POINTAPI
X As Long
Y As Long
End Type
' Constants required by TrackPopupMenu
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_TOPALIGN = &H0
Private Const TPM_RETURNCMD = &H100
Private Const TPM_RIGHTBUTTON = &H2&
' Constants required by MENUITEMINFO type
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MFT_STRING = &H0
Private Const MFT_SEPARATOR = &H800
Private Const MFS_DEFAULT = &H1000
Private Const MFS_ENABLED = &H0
Private Const MFS_GRAYED = &H1
' Contants defined by me for menu item IDs
Private Const ID_Cut = 101
Private Const ID_Copy = 102
Private Const ID_Paste = 103
Private Const ID_Delete = 104
Private Const ID_SelectAll = 105
' Variables declared at module level
Private FormCaption As String
Private Cut_Enabled As Long
Private Copy_Enabled As Long
Private Paste_Enabled As Long
Private Delete_Enabled As Long
Private SelectAll_Enabled As Long
Public Sub ShowPopup(oForm As UserForm, strCaption As String, X As Single, Y As Single)
Dim oControl As MSForms.TextBox
Static click_flag As Long
' The following is required because the MouseDown event
' fires twice when right-clicked !!
click_flag = click_flag + 1
' Do nothing on first firing of MouseDown event
If (click_flag Mod 2 <> 0) Then Exit Sub
' Set object reference to the textboxthat was clicked
'Set oControl = oForm.ActiveControl
' If click is outside the textbox, do nothing
'If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub
' Retrieve caption of UserForm for use in FindWindow API
FormCaption = strCaption
' Call routine that sets menu items as enabled/disabled
Call EnableMenuItems(oForm)
' Call function that shows the menu and return the ID
' of the selected menu item. Subsequent action depends
' on the returned ID.
Select Case GetSelection()
Case ID_Cut
oControl.Cut
Case ID_Copy
oControl.Copy
Case ID_Paste
oControl.Paste
Case ID_Delete
oControl.SelText = ""
Case ID_SelectAll
With oControl
.SelStart = 0
.SelLength = Len(oControl.Text)
End With
End Select
End Sub
Private Sub EnableMenuItems(oForm As UserForm)
Dim oControl As MSForms.TextBox
Dim oData As DataObject
Dim testClipBoard As String
On Error Resume Next
' Set object variable to clicked textbox
Set oControl = oForm.ActiveControl
' Create DataObject to access the clipboard
Set oData = New DataObject
' Enable Cut/Copy/Delete menu items if text selected
' in textbox
If oControl.SelLength > 0 Then
Cut_Enabled = MFS_ENABLED
Copy_Enabled = MFS_ENABLED
Delete_Enabled = MFS_ENABLED
Else
Cut_Enabled = MFS_GRAYED
Copy_Enabled = MFS_GRAYED
Delete_Enabled = MFS_GRAYED
End If
' Enable SelectAll menu item if there is any text in textbox
If Len(oControl.Text) > 0 Then
SelectAll_Enabled = MFS_ENABLED
Else
SelectAll_Enabled = MFS_GRAYED
End If
' Get data from clipbaord
oData.GetFromClipboard
' Following line generates an error if there
' is no text in clipboard
testClipBoard = oData.GetText
' If NO error (ie there is text in clipboard) then
' enable Paste menu item. Otherwise, diable it.
If Err.Number = 0 Then
Paste_Enabled = MFS_ENABLED
Else
Paste_Enabled = MFS_GRAYED
End If
' Clear the error object
Err.Clear
' Clean up object references
Set oControl = Nothing
Set oData = Nothing
End Sub
Private Function GetSelection() As Long
Dim menu_hwnd As Long
Dim form_hwnd As Long
Dim oMenuItemInfo1 As MENUITEMINFO
Dim oMenuItemInfo2 As MENUITEMINFO
Dim oMenuItemInfo3 As MENUITEMINFO
Dim oMenuItemInfo4 As MENUITEMINFO
Dim oMenuItemInfo5 As MENUITEMINFO
Dim oMenuItemInfo6 As MENUITEMINFO
Dim oRect As RECT
Dim oPointAPI As POINTAPI
' Find hwnd of UserForm - note different classname
' Word 97 vs Word2000
#If VBA6 Then
form_hwnd = FindWindow("ThunderDFrame", FormCaption)
#Else
form_hwnd = FindWindow("ThunderXFrame", FormCaption)
#End If
' Get current cursor position
' Menu will be drawn at this location
GetCursorPos oPointAPI
' Create new popup menu
menu_hwnd = CreatePopupMenu
' Intitialize MenuItemInfo structures for the 6
' menu items to be added
' Cut
With oMenuItemInfo1
.cbSize = Len(oMenuItemInfo1)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Cut_Enabled
.wID = ID_Cut
.dwTypeData = "Cut"
.cch = Len(.dwTypeData)
End With
' Copy
With oMenuItemInfo2
.cbSize = Len(oMenuItemInfo2)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Copy_Enabled
.wID = ID_Copy
.dwTypeData = "Copy"
.cch = Len(.dwTypeData)
End With
' Paste
With oMenuItemInfo3
.cbSize = Len(oMenuItemInfo3)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Paste_Enabled
.wID = ID_Paste
.dwTypeData = "Paste"
.cch = Len(.dwTypeData)
End With
' Separator
With oMenuItemInfo4
.cbSize = Len(oMenuItemInfo4)
.fMask = MIIM_TYPE
.fType = MFT_SEPARATOR
End With
' Delete
With oMenuItemInfo5
.cbSize = Len(oMenuItemInfo5)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Delete_Enabled
.wID = ID_Delete
.dwTypeData = "Delete"
.cch = Len(.dwTypeData)
End With
' SelectAll
With oMenuItemInfo6
.cbSize = Len(oMenuItemInfo6)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = SelectAll_Enabled
.wID = ID_SelectAll
.dwTypeData = "Select All"
.cch = Len(.dwTypeData)
End With
' Add the 6 menu items
InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6
' Return the ID of the item selected by the user
' and set it the return value of the function
GetSelection = TrackPopupMenu _
(menu_hwnd, _
TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
oPointAPI.X, oPointAPI.Y, _
0, form_hwnd, oRect)
' Destroy the menu
DestroyMenu menu_hwnd
End Function |
Menu contextuel sur UserForm
Répondre avec citation
Partager