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