请教：如何能使在VBA中窗体上的文本框上单击右键出现快捷菜单

qtds3386

象VB中那样的效果能不能做到啊？没有复制和粘帖功能，增强属性的编辑就不如CAD在里做了，做个窗体就没太大意义了。

asd_10000

添加一个模块

Option Explicit
Public hwnd As Long
Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type
Type POINTAPI
     x As Long
     Y As Long
End Type
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function CreatePopupMenu Lib "user32" () As Long
Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
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)
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long




Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function CloseClipboard Lib "user32" () As Long




在窗体中增加以下语句
Private Sub 工作目录TextBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
If Button = 2 Then      '右击显示弹出式菜单
      Dim CurrentPoint As POINTAPI
      GetCursorPos CurrentPoint
      Call ShowPopMenu_Txt(工作目录TextBox, CurrentPoint.x, CurrentPoint.Y)
   End If
End Sub
Sub ShowPopMenu_Txt(ctr As MSForms.TextBox, ByVal x As Single, ByVal Y As Single)  ' 定义并显示弹出式菜单
    Dim hMenu As Long, lOption As Long
    Dim rct As RECT, iAns As Integer
    hMenu = CreatePopupMenu '建立一级弹出菜单
    AppendMenu hMenu, 0 Or lOption, 1, "复制"  '增加菜单条目
    AppendMenu hMenu, 0 Or lOption, 2, "剪切"  '增加菜单条目
    AppendMenu hMenu, 0 Or lOption, 3, "贴贴"  '增加菜单条目
    iAns = TrackPopupMenu(hMenu, 256, x, Y, 0, hwnd, rct)
    '显示弹出式菜单并返回选取条目命令
       Call PopMenuAction_Txt(ctr, ByVal iAns) '执行条目代码
        DestroyMenu hMenu '销毁弹出菜单
End Sub

Sub PopMenuAction_Txt(ctr As MSForms.TextBox, ByVal CommandID As Integer) '执行菜单条目代码
    Select Case CommandID
        Case 1
            ctr.Copy
        Case 2
            ctr.Cut
        Case 3
            ctr.Paste
    End Select
End Sub