Private Sub uTextBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And m_Read = True Then
OldWindowProc = GetWindowLong(uTextBox.hWnd, GWL_WNDPROC)
' 取得窗口函数的地址
Call SetWindowLong(uTextBox.hWnd, GWL_WNDPROC, AddressOf SubClass_WndMessage)
' 用SubClass_WndMessage代替窗口函数处理消息
End If
End Sub
Private Sub uTextBox_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And m_Read = True Then
Call SetWindowLong(uTextBox.hWnd, GWL_WNDPROC, OldWindowProc)
' 恢复窗口的默认函数
' 弹出自定义菜单
If Not m_Menu Is Nothing Then
If TypeOf m_Menu Is Menu Then
PopupMenu m_Menu
End If
End If
End If
End Sub
Private Sub UserControl_Resize()
With UserControl
uTextBox.Move .ScaleLeft, .ScaleTop, .ScaleWidth, .ScaleHeight
End With
End Sub
Public Property Let BackColor(ByVal vNewValue As OLE_COLOR)
Let m_BackColor = vNewValue
Let uTextBox.BackColor = vNewValue
Let UserControl.BackColor = vNewValue
End Property
Public Property Get BackColor() As OLE_COLOR
Let BackColor = m_BackColor
End Property
Public Property Let Text(ByVal vNewValue As String)
Let uTextBox.Text = vNewValue
End Property
Public Property Get Text() As String
Let Text = uTextBox.Text
End Property
Public Property Let Alignment(ByVal vNewValue As VBRUN.AlignmentConstants)
Let m_TextAlig = vNewValue
Let uTextBox.Alignment = vNewValue
End Property
Public Property Get Alignment() As VBRUN.AlignmentConstants
Let Alignment = m_TextAlig
End Property
Public Property Let ReadOnly(ByVal vNewValue As Boolean)
Let m_Read = vNewValue
Let uTextBox.Locked = vNewValue
End Property
Public Property Get ReadOnly() As Boolean
Let ReadOnly = m_Read
End Property
Private Sub uTextBox_Change()
RaiseEvent Change
End Sub
Public Property Set Menu(ByRef vNewValue As Menu)
Set m_Menu = vNewValue
End Property
Public Property Get Menu() As Menu
Set Menu = m_Menu
End Property
Public Property Let MaxLength(ByVal vNewValue As Integer)
Let m_MaxLength = vNewValue
Let uTextBox.MaxLength = vNewValue
End Property
Public Property Get MaxLength() As Integer
Let MaxLength = m_MaxLength
End Property
Public Property Let SelLength(ByVal vNewValue As Integer)
'Let m_SelLength = vNewValue
Let uTextBox.SelLength = vNewValue
End Property
Public Property Get SelLength() As Integer
Let SelLength = uTextBox.SelLength
End Property
Public Property Let SelStart(ByVal vNewValue As Integer)
Let uTextBox.SelStart = vNewValue
End Property
Public Property Get SelStart() As Integer
Let SelStart = uTextBox.SelStart
End Property
Public Property Let SelText(ByVal vNewValue As String)
Let uTextBox.SelText = vNewValue
End Property
Public Property Get SelText() As String
Let SelText = uTextBox.SelText
End Property
'Public Property Let MulitLine(ByVal vNewValue As Boolean)
' Let uTextBox.MultiLine = vNewValue
'End Property
'Public Property Get MultiLine() As Boolean
' Let MulitLine = uTextBox.MulitLine
'End Property
'Public Property Let ScrollBars(ByVal vNewValue As VBRUN.ScrollBarConstants)
' Let uTextBox.ScrollBars = vNewValue
'End Property
'Public Property Get ScrollBars() As VBRUN.ScrollBarConstants
' Let ScrollBars = uTextBox.ScrollBars
'End Property
Public Property Let Enabled(ByVal vNewValue As Boolean)
Let m_Enabled = vNewValue
Let uTextBox.Enabled = vNewValue
Let UserControl.Enabled = vNewValue
End Property
Public Property Get Enabled() As Boolean
Let Enabled = m_Enabled
End Property
完整实现代码如下:
’核心代码的代码
'uTextBox 是你要屏蔽的文本控件 m_Menu 是你要弹出的菜单 m_Read标记是否锁定
Private Sub uTextBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And m_Read = True Then
OldWindowProc = GetWindowLong(uTextBox.hWnd, GWL_WNDPROC)
' 取得窗口函数的地址
Call SetWindowLong(uTextBox.hWnd, GWL_WNDPROC, AddressOf SubClass_WndMessage)
' 用SubClass_WndMessage代替窗口函数处理消息
End If
End Sub
Private Sub uTextBox_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And m_Read = True Then
Call SetWindowLong(uTextBox.hWnd, GWL_WNDPROC, OldWindowProc)
' 恢复窗口的默认函数
' 弹出自定义菜单
If Not m_Menu Is Nothing Then
If TypeOf m_Menu Is Menu Then
PopupMenu m_Menu
End If
End If
End If
End Sub
'以下放置在模块中
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 Function SubClass_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
SubClass_WndMessage = CallWindowProc(OldWindowProc, hWnd, Msg, wp, lp)
' 如果消息不是WM_CONTEXTMENU,就调用默认的窗口函数处理
Exit Function
End If
SubClass_WndMessage = True
End Function
Private m_BackColor As OLE_COLOR '颜色
Private m_MaxLength As Integer '长度
Private m_TextAlig As VBRUN.AlignmentConstants '文本位置
Private m_Menu As Menu '自定义菜单
Private m_Read As Boolean '是否可读
Private m_Enabled As Boolean 'Enabled
'Private m_MulitLine As Boolean '换行
Private Const m_DefBackColor = &H80000018 '默认文本背景颜色
Public Event Change() '文本修改事件
Public Event Click() 'click事件
Private Sub UserControl_Initialize()
Call UserControl_Resize
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Let BackColor = PropBag.ReadProperty("BackColor", m_DefBackColor)
Let MaxLength = PropBag.ReadProperty("MaxLength", 0)
Let Text = PropBag.ReadProperty("Text", "")
Let Alignment = PropBag.ReadProperty("Alignment", 0)
Set Menu = PropBag.ReadProperty("Menu", Nothing)
Let ReadOnly = PropBag.ReadProperty("Read", False)
Let Enabled = PropBag.ReadProperty("Enabled", True)
' Let uTextBox.MultiLine = PropBag.ReadProperty("MultiLine", False)
'Let uTextBox.ScrollBars = PropBag.ReadProperty("ScrollBars", 0)
End Sub
Option Explicit
Private 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
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_CONTEXTMENU As Long = &H7B
Public defWndProc As Long
Public Sub Hook(hwnd As Long)
If defWndProc = 0 Then
defWndProc = SetWindowLong(hwnd, _
GWL_WNDPROC, _
AddressOf WindowProc)
End If
'Form Code
'To a form, add a top level menu (mnuPopup), and any number of submenu items under it. Add a text box (Text1), and two command buttons (Command1, Command2) to the form along with the following code:
'just in case, assure the
'texbox is unhooked before exiting
Call UnHook(Text1.hwnd)
End Sub
Private Sub Text1_MouseUp(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
'this executes only when the window is unhooked
'and shows the default behaviour - first the
'generic textbox menu is shown, then on closing
'the custom textbox popup appears
If defWndProc = 0 Then
If Button = vbRightButton Then
PopupMenu mnuPopup
End If
End If