程式師世界 >> 編程語言 >> .NET網頁編程 >> .NET實例教程 >> VB TextBox 簡易擴展

VB TextBox 簡易擴展

編輯：.NET實例教程

   這幾天公司事情比較少，所以就想著把以前寫的一些代碼貼出來，希望能夠拋磚引玉。從這篇開始，我將陸陸續續貼出一些代碼，希望能對初學者有些幫助，也希望高手批評和賜教。下面我們開始進入正題。
       在平時軟件開發過程中，或多或少總是要使用到一些文本框控件，但是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 = "禁止右鍵菜單"

an>    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

哈哈，終於寫好了，出去外面轉轉先。如果有什麼錯誤的地方或更好的方法，希望大家批評指點，我的郵箱： [email protected]。