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
| Option Explicit
' http://word.mvps.org/faqs/userforms/AddRightClickMenu.htm
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
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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
Private Type POINTAPI
X As Long
Y As Long
End Type
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
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
' 97 vs 2007
#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 = "Couper"
.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 = "Copier"
.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 = "Coller"
.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 = "Supprimer"
.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 = "Tout Sélectionner"
.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 |
Partager