【转】VB TextBox 简易扩展

       在平时软件开发过程中，或多或少总是要使用到一些文本框控件，但是VB6自带的TextBox有时无法满足我们的一些需求，比如使其只能输入数字，禁止右键弹出其自带的菜单或者使用自己的菜单，计算多行文本框的行数，让多行文本框的滚动条总是滚动到最后一行等等，为了方便平时的编程，我将上面提到的这些封装成一个类CTextBoxEx，代码如下：
 
'*************************************************************************
'**模 块 名：CTextBoxEx
'**版    权：Zezesesoft Studio 版权所有 2006-2008(C)
'**创 建 人：张志松
'**日    期：2006-11-01
'**修 改 人：
'**修改时间：
'**描    述：
'**版    本：1.0.0
'*************************************************************************
Option Explicit
'接口继承
Implements ISubclass
Private Const CurrentModule As String = "CTextBoxEx"
Private Const WM_CONTEXTMENU = &H7B
Private Const EM_GETLINE = &HC4
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINELENGTH = &HC1
Private Const EM_LINEINDEX = &HBB
Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_PAGEDOWN = 3
Private Const SB_TOP = 6
Private Const SB_PAGEUP = 2
Private Const SB_BOTTOM = 7
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private WithEvents m_TextBox  As TextBox
Private mvarEnableContextMenu As Boolean
Private mvarInPutNumberOnly   As Boolean
Private Sub Class_Initialize()
    '默认允许右键菜单
    mvarEnableContextMenu = True
End Sub
Private Sub Class_Terminate()
    Set m_TextBox = Nothing
End Sub
'接口实现
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
    '
End Property
Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
    '
End Property
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '
End Function
'绑定到一个TextBox控件
Public Sub BindTextBox(ByVal aTextBox As TextBox)
    On Error Resume Next
    If aTextBox Is Nothing Then Exit Sub
   
    If m_TextBox Is aTextBox Then Exit Sub
   
    Set m_TextBox = aTextBox
   
    If mvarEnableContextMenu Then
        DetachMessage Me, m_TextBox.hwnd, WM_CONTEXTMENU
    Else
        AttachMessage Me, m_TextBox.hwnd, WM_CONTEXTMENU
    End If
End Sub
'多行文本框的滚动条滚动到最后一行
Public Sub ScrollToBottom()
    If m_TextBox Is Nothing Then Exit Sub
    SendMessage m_TextBox.hwnd, WM_VSCROLL, SB_BOTTOM, ByVal 0&
End Sub
'设置是否只能输入数字
Public Property Let InPutNumberOnly(ByVal vData As Boolean)
    mvarInPutNumberOnly = vData
End Property
Public Property Get InPutNumberOnly() As Boolean
    InPutNumberOnly = mvarInPutNumberOnly
End Property
'设置是否允许自带的右键菜单
Public Property Let EnableContextMenu(ByVal vData As Boolean)
    If mvarEnableContextMenu = vData Then Exit Property
    mvarEnableContextMenu = vData
    If m_TextBox Is Nothing Then Exit Property
    If vData Then
        DetachMessage Me, m_TextBox.hwnd, WM_CONTEXTMENU
    Else
        AttachMessage Me, m_TextBox.hwnd, WM_CONTEXTMENU
    End If
End Property
Public Property Get EnableContextMenu() As Boolean
    EnableContextMenu = mvarEnableContextMenu
End Property
Public Property Get LineCount() As Long
    If m_TextBox Is Nothing Then Exit Property
    LineCount = SendMessage(m_TextBox.hwnd, EM_GETLINECOUNT, 0, 0)
End Property
'得到指定行的文本长度，LineIndex 从0开始
Public Property Get LineLength(ByVal LineIndex As Long) As Long 'zero-based
    Dim r As Long
    If m_TextBox Is Nothing Then Exit Property
    r = SendMessage(m_TextBox.hwnd, EM_LINEINDEX, LineIndex, ByVal 0&)
    LineLength = SendMessage(m_TextBox.hwnd, EM_LINELENGTH, r, ByVal 0&)
End Property
'得到指定行的文本，LineIndex 从0开始
Public Property Get LineText(ByVal LineIndex As Long) As String 'zero-based
    Dim strArray(255) As Byte
    Dim str As String, r As Long
    If m_TextBox Is Nothing Then Exit Property
    strArray(0) = 255
    r = SendMessage(m_TextBox.hwnd, EM_GETLINE, LineIndex, strArray(0))
    If r = 0 Then
       LineText = ""
    Else
       str = StrConv(strArray, vbUnicode)
       LineText = Left(str, InStr(1, str, Chr(0)) - 1)
    End If
End Property
'文本框事件
Private Sub m_TextBox_KeyPress(KeyAscii As Integer)
    If Me.InPutNumberOnly Then
        If (KeyAscii < vbKey0 Or KeyAscii > vbKey9) And KeyAscii <> vbKeyBack And KeyAscii <> vbKeyDelete Then
            KeyAscii = 0
        End If
    End If
End Sub
 
       上面的代码用到了接口ISubClass，可以从http://www.vbaccelerator.com/home/VB/Code/Libraries/Subclassing/SSubTimer/VB6_SSubTmr_Binary.zip这里链接下载，然后用regsvr32.exe注册该库文件就可使用了。
 
       下面给出一个例子，在窗体上放一个TextBox，一个CommandButton和两个CheckBox，手工设置Text1的MultiLine=True。代码如下：
 
Option Explicit
 
Private MyTextBox As CTextBoxEx
 
Private Sub Form_Load()
    Me.Check1.Caption = "禁止右键菜单"
    Me.Check2.Caption = "只能输入数字"
    Me.Command1.Caption = "单击我"
    Me.Caption = "CTextBox 使用示例"
    Set MyTextBox = New CTextBoxEx
    '绑定到Text1
    MyTextBox.BindTextBox Me.Text1
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Set MyTextBox = Nothing
End Sub
 
Private Sub Check1_Click()
    MyTextBox.EnableContextMenu = Abs(Check1.Value - 1)
End Sub
 
Private Sub Check2_Click()
    MyTextBox.InPutNumberOnly = Check2.Value
End Sub
 
Private Sub Command1_Click()
    Debug.Print MyTextBox.LineCount
    Debug.Print MyTextBox.LineLength(0)
    Debug.Print MyTextBox.LineText(0)
End Sub

详细出处参考：http://www.itqun.net/content-detail/158831.html