请问在文本框textbox中，有办法用自定义菜单代替默认菜单吗?

Question

各位大虾,我已定义数组变量产生了不带事件文本框,用户要求在产生的文本框中也产生右键菜单
请问高招用自定义菜单代替默认菜单吗?
Public txt() As Control
Private Sub Form_Load()
reDim Txt(1)
  Set Txt(1)= Me.Controls.Add("VB.TextBox", "txt1" ,me)
  Txt(1).Caption = Adodc1.Recordset("controlsdes")
  Txt(1).txt.Top = 10
  Txt(1).Left = 10
  Txt(1).Height = 300
  Txt(1).Width = 1000
  Txt(1).Visible = True
End Sub

Answer 1

使用“钩子”建立一个Form和一个Model:Model1代码:Option Explicit
Public txt() As Control
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = -4
Public Const WM_RBUTTONUP = &H205
Public lpPrevWndProc As Long
Private lngHWnd As LongPublic Sub Hook(hWnd As Long)
  lngHWnd = hWnd
  lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHook()
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _
   ByVal wParam As Long, ByVal _
   lParam As Long) As Long
   Select Case uMsg
'检测鼠标击键消息，如果是单击右键
   Case WM_RBUTTONUP
'什么事也不做或弹出自己定制的菜单
    MsgBox "right button clicked."
    Exit Function
   Case Else
    WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    Debug.Print hw, uMsg, wParam, lParam, ":" & WindowProc
   End Select
End FunctionForm1代码：Private Sub Form_Load()
    ReDim txt(1)
      Set txt(1) = Me.Controls.Add("VB.TextBox", "txt1", Me)
      txt(1).Top = 10
      txt(1).Left = 10
      txt(1).Height = 300
      txt(1).Width = 1000
      txt(1).Visible = True      
      Call Hook(txt(1).hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
   Call UnHook
End Sub

Answer 2

子类化(SubClassing)或超类化(SuperClassing)

Answer 3

''外 内置鼠标右键菜单也要屏蔽(API Hook)
'
'Form1: Text1Option ExplicitPrivate Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)If KeyCode = vbKeyControl Then  If Len(Clipboard.GetText) > 0 Then      Clipboard.Clear  End IfEnd IfEnd SubPrivate Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = vbRightButton Then   OldWindowProc = GetWindowLong(Text1.hWnd, GWL_WNDPROC)   ' 取得窗口函数的地址   Call SetWindowLong(Text1.hWnd, GWL_WNDPROC, AddressOf SubClass1_WndMessage)   ' 用SubClass1_WndMessage代替窗口函数处理消息End IfEnd SubPrivate Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = vbRightButton Then   Call SetWindowLong(Text1.hWnd, GWL_WNDPROC, OldWindowProc)   ' 恢复窗口的默认函数   ' 弹出自定义菜单End IfEnd Sub
'Module1:Option ExplicitPublic OldWindowProc As Long' 保存默认的窗口函数的地址Public Const WM_CONTEXTMENU = &H7B' 当右击文本框时，产生这条消息Public Const GWL_WNDPROC = (-4)Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Function SubClass1_WndMessage(ByVal hWnd As OLE_HANDLE, ByVal Msg As OLE_HANDLE, ByVal wp As OLE_HANDLE, ByVal lp As Long) As LongIf Msg = WM_CONTEXTMENU Then   SubClass1_WndMessage = TrueElse   SubClass1_WndMessage = CallWindowProc(OldWindowProc, hWnd, Msg, wp, lp)   ' 如果消息不是WM_CONTEXTMENU，就调用默认的窗口函数处理End IfEnd Function

Answer 4

'在屏蔽多个文本框时，最好这么做。SetProp ，GetProp，RemoveProp API最好运用
Private Sub txtFlag_GotFocus(Index As Integer)
  If vscBar.Visible = True Then Hook txtFlag(Index).hWnd    '加载钩子
End SubPrivate Sub txtFlag_LostFocus(Index As Integer)
  If vscBar.Visible = True Then UnHook txtFlag(Index).hWnd  '卸载钩子
End SubPrivate Sub txtFlag_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   '打开错误处理陷阱
   On Error GoTo ErrGoto
   '----------------------------------------------------
   '代码正文
    If Button = 2 Then
       ' 取得窗口函数的地址
       SetProp GetWindowLong(txtFlag(Index).hWnd, GWL_WNDPROC), "HWND", GetWindowLong(txtFlag(Index).hWnd, GWL_WNDPROC)
       ' 用SubClass1_WndMessage代替窗口函数处理消息
       Call SetWindowLong(txtFlag(Index).hWnd, GWL_WNDPROC, AddressOf SubClass1_WndMessage)
    End If
   '----------------------------------------------------
   Exit Sub
   '-----------------------------
ErrGoto:
  
End SubPrivate Sub txtFlag_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   '打开错误处理陷阱
   On Error GoTo ErrGoto
   '----------------------------------------------------
   '代码正文
   If Button = 2 Then
       ' 恢复窗口的默认函数
        Call SetWindowLong(txtFlag(Index).hWnd, GWL_WNDPROC, GetProp(GetWindowLong(txtFlag(Index).hWnd, GWL_WNDPROC), "HWND"))
        RemoveProp GetWindowLong(txtFlag(Index).hWnd, GWL_WNDPROC), "HWND"
        
       ' 弹出自定义菜单
       
          PopupMenu ***
       
   End If
   '----------------------------------------------------
   Exit Sub
   '-----------------------------
ErrGoto:
End Sub‘模块Public Function SubClass1_WndMessage(ByVal hWnd As OLE_HANDLE, ByVal Msg As OLE_HANDLE, ByVal wp As OLE_HANDLE, ByVal lp As Long) As Long
    If Msg = WM_CONTEXTMENU Then
         SubClass1_WndMessage = True
    Else
       SubClass1_WndMessage = CallWindowProc(OldWindowProc, hWnd, Msg, wp, lp)
       ' 如果消息不是WM_CONTEXTMENU，就调用默认的窗口函数处理
    End IfEnd Function

Answer 5

用以上高手们的方法是比较完善的解决方式，另外我看到别人也有这么用的：Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)   If Button = 2 Then
      Text1.Enabled = False
      Text1.Enabled = True
      PopupMenu YourMenu
   End If
End Sub