📄 frmextend.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "标准控件的高级编程"
ClientHeight = 6930
ClientLeft = 60
ClientTop = 345
ClientWidth = 8430
LinkTopic = "Form1"
ScaleHeight = 6930
ScaleWidth = 8430
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdAdd
Caption = "加入列表框"
Height = 375
Left = 6480
TabIndex = 13
Top = 3120
Width = 1335
End
Begin VB.ListBox lstExtend
Height = 2400
Left = 4080
TabIndex = 11
Top = 4200
Width = 3375
End
Begin VB.TextBox txtList
Height = 375
Left = 4080
TabIndex = 10
Top = 3120
Width = 2295
End
Begin VB.TextBox txtLine
Height = 495
Left = 3960
TabIndex = 8
Top = 1080
Width = 1815
End
Begin VB.TextBox txtShow
Height = 495
Left = 5640
TabIndex = 7
Top = 1800
Width = 2175
End
Begin VB.CommandButton cmdShow
Caption = "读取指定行文本"
Height = 495
Left = 6120
TabIndex = 5
Top = 1080
Width = 1695
End
Begin VB.ComboBox cboExtend
Height = 315
Left = 960
TabIndex = 2
Top = 4080
Width = 2535
End
Begin VB.TextBox txtExtend
BorderStyle = 0 'None
Height = 525
Left = 840
MultiLine = -1 'True
TabIndex = 0
Top = 1080
Width = 1695
End
Begin VB.Label Label6
Caption = "禁止重复添加项的列表框："
Height = 375
Left = 4080
TabIndex = 12
Top = 3720
Width = 2175
End
Begin VB.Label Label5
Caption = "输入要添加到列表框中的项："
Height = 375
Left = 3960
TabIndex = 9
Top = 2640
Width = 2415
End
Begin VB.Label Label4
Caption = "显示读出的内容："
Height = 375
Left = 3960
TabIndex = 6
Top = 1920
Width = 1575
End
Begin VB.Label Label3
Caption = " 输入需要读取的多行文本框中的行数（请严格输入正整数）："
Height = 615
Left = 3960
TabIndex = 4
Top = 240
Width = 3255
End
Begin VB.Label Label2
Caption = "具有扩展特性的组合框："
Height = 375
Left = 480
TabIndex = 3
Top = 3480
Width = 2535
End
Begin VB.Label Label1
Caption = "具有扩展特性的文本框："
Height = 375
Left = 240
TabIndex = 1
Top = 240
Width = 2415
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'实现自动查询组合框内容所需的API函数声明，还有更广泛的用途
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lPram As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Const EM_GETLINE = &HC4
Private Const EM_LINELENGTH = &HC1
Private Const EM_LINEINDEX = &HBB
Private Const WM_USER = &H400
Private Const LB_ERR = (-1)
Private Const LB_FINDSTRING = &H18F '该消息用来在列表框中进行字符串匹配搜索
Private Const CB_FINDSTRING = &H14C '该消息用来在组合框中进行字符串匹配搜索
Private Const EM_GETLINECOUNT = &HBA '该消息用来获取文本框中的行数
Private Const BACKSPACE = 8
Private Const DELETE = 46
Dim LastLine As Long '最后的行数
Dim LineHeight As Long '每行的高度
Dim m_AutoSelect As Boolean '该公用变量用来存放 判断是否执行组合框自动选择功能的状态
'******************************************************
'功能：检测要添加的项目是否已经存在于列表框
'输入：
' ctlTem Control 控件类型
' 因为该过程可以对列表框和组合框通用,所以不指定控件类型
' strTem string 要添加的字符串
'输出: 无
'******************************************************
Sub CheckItem(ByVal ctlTem As Control, ByVal strTem As String)
Dim Ret As Long
Dim strItem As String
strItem = strTem
If TypeName(ctlTem) = "ListBox" Then
'注意，此处参数strItem需要指明ByVal传递，否则不能得到正确结果
Ret = SendMessage(ctlTem.hwnd, LB_FINDSTRING, -1, ByVal strItem)
ElseIf TypeName(ctlTem) = "ComboBox" Then
Ret = SendMessage(ctlTem.hwnd, CB_FINDSTRING, -1, ByVal strItem)
End If
If Ret = LB_ERR Then '如果没有发现重复的项，则添加项目
ctlTem.AddItem strItem
Else
ctlTem.ListIndex = Ret
MsgBox "不能加入重复的值！"
End If
End Sub
'******************************************************
'功能：获取文本框中指定行的文本
'输入：
' hwnd Long 控件句柄
' lngLine Long 指定的行号
' strLine String 返回的字符串
'输出: 无
'影响: 参数strLine 用来存放从文本框中获取的字符串
'TextBox是以VBcr+VBlf为分隔符，如果逐一读取TextBox的每一行，
'就要逐行找该分隔符。这样的方法是很慢的。
'本过程所提供的方法，调用API函数直接读取指定行的文本，执行速
'度很快。
'******************************************************
Sub TxtGetLine(ByVal hwnd As Long, ByVal lngLine As Long, ByRef strLine As String)
Dim Length As Long '某一行的长度
Dim Barr() As Byte, Barr2() As Byte '用来存放指定行的内容
Dim lngIndex As Long '文本框中行的序号
'根据给定行取得行的索引号
lngIndex = SendMessage(hwnd, EM_LINEINDEX, lngLine, ByVal 0&)
'根据行索引取得该行的长度
Length = SendMessage(hwnd, EM_LINELENGTH, lngIndex, ByVal 0&)
If Length > 0 Then
ReDim Barr(Length + 1) As Byte
ReDim Barr2(Length + 1) As Byte
Call CopyMemory(Barr(0), Length, 2)
Call SendMessage(hwnd, EM_GETLINE, lngLine, Barr(0))
Call CopyMemory(Barr2(0), Barr(0), Length)
'将字节型数组中的内容转换为字符串
strLine = StrConv(Barr2, vbUnicode)
Else
strLine = vbNullString
End If
End Sub
'******************************************************
'功能:根据输入字符自动搜索组合框中存在项，看是否匹配，
' 并且显示在输入框中
'******************************************************
Private Sub cboExtend_Change()
Dim iStart As Long '定义被选择字符的起始位置
Dim sString As String '用来存放在cboExtend控件中获取的子字符串
If m_AutoSelect = True Then '为真，则执行自动选择
iStart = 1 '只是初始化的作用
iStart = cboExtend.SelStart '设置iStart为组合框中文本被选择区域的开始位置
'取得当前输入字符以及以前输入字符所形成的字符串，保存于变量sString中
sString = CStr(Left(cboExtend.Text, iStart))
'利用API函数去执行搜索、匹配字符串的工作
cboExtend.ListIndex = SendMessage(cboExtend.hwnd, CB_FINDSTRING, -1, ByVal _
CStr(Left(cboExtend.Text, iStart)))
If cboExtend.ListIndex = -1 Then '如果没有找到匹配的字符串，则保留当前的输入
cboExtend.Text = sString
End If
'将iStart的值设置为选择区域的开始位置，即选择区域往后移动一个字符
cboExtend.SelStart = iStart
'设置被选中的区域长度
cboExtend.SelLength = Len(cboExtend.Text) - iStart
End If
End Sub
'***********************************************************
'功能： 加入这样的代码，是为了在删除字符时候不至于一直执行
' 自动查找选择的功能
'***********************************************************
Private Sub cboExtend_KeyPress(KeyAscii As Integer)
If KeyAscii = BACKSPACE Then '如果是退格键，则不执行自动选择
m_AutoSelect = False
Else '如果是别的输入，则执行自动选择
m_AutoSelect = True
End If
End Sub
Private Sub cmdAdd_Click()
Dim strTem As String
strTem = Trim$(txtList.Text)
Call CheckItem(lstExtend, strTem)
End Sub
Private Sub cmdShow_Click()
Dim strTem As String
Dim numLine As Long
'为何要减1？因为TextBox行数从0算起，如果输入2的话，一般
'希望取得我们看上去的第二行。即序数为1的那行文本
'注意，由于只是测试程序，这里没有出错控制，请严格输入正整数
numLine = CLng(Trim$(txtLine.Text)) - 1
Call TxtGetLine(txtExtend.hwnd, numLine, strTem)
txtShow.Text = strTem
End Sub
Private Sub Form_Load()
'初始化组合框
cboExtend.AddItem "Students"
cboExtend.AddItem "Teachers"
cboExtend.AddItem "Workers"
cboExtend.AddItem "Clerks"
'初始化列表框
lstExtend.AddItem "Students"
lstExtend.AddItem "Teachers"
lstExtend.AddItem "Workers"
lstExtend.AddItem "Clerks"
'设定文本框中每行的高度
Set Me.Font = txtExtend.Font
LineHeight = Me.TextHeight("A")
End Sub
'*************************************************************
'功能：改变文本框的高度。高度随着行数的变化而变化，与GetFocus结合
' 使用。此时，需要设置TextBox的MultiLine属性为真。本例演示的
' 是不设置ScroolBar，通过代码自由得改变文本框高度的方法。为了正
' 的运行程序，把文本框的边框BorderStyle设置为0_None，否则，每次输
' 入的第一行文本都不能显示出来。
'*************************************************************
Private Sub txtExtend_Change()
Dim Ret As Long '定义存放文本框中行数的变量
Ret = SendMessage(txtExtend.hwnd, EM_GETLINECOUNT, 0, 0&)
If Ret <> LastLine Then '判断Ret与最后的行数LastLine是否相等
'该语句判断文本框高度是否已经合窗体高度一样，同时看是否存
'在多行文本
If txtExtend.Height + txtExtend.Top + LineHeight > _
Me.ScaleHeight And Ret > 1 Then
'判断最终的行数（LastLine）是否小于或等于目前行数（Ret）减1的
If LastLine <= Ret - 1 Then
Exit Sub '如果已经是最大高度，则保持
End If
LastLine = Ret - 1 '超过最大高度，需要控制
Else
LastLine = Ret '取得行数赋给LastLine
End If
'在最大高度范围内获取了最终的行数，然后来确定高度
txtExtend.Height = LastLine * LineHeight '修改高度
End If
End Sub
'***************************************************
'功能： 1.自动选择文本；2.获取文本框中的行数
'***************************************************
Private Sub txtExtend_GotFocus()
'文本框控件获得焦点，就将文本框内容全部选中
txtExtend.SelStart = 0
txtExtend.SelLength = Len(Trim$(txtExtend.Text))
'获取文本框中的行数
LastLine = SendMessage(txtExtend.hwnd, EM_GETLINECOUNT, 0, 0&)
End Sub
'******************************************************
'功能：实现文本框中输入字符限制
'******************************************************
Private Sub txtExtend_KeyPress(KeyAscii As Integer)
'用Select Case比用If语句选择余地大，这个功能使得文本框只能输入
'数字和小数点“.”同时也能响应BackSpace键
Select Case KeyAscii
Case 48 To 57 '如果是数字，则允许输入
Case 46, 8 '如果是.和退格键BackSpace也能正确响应
Case 13 '如果是回车键，则执行相关操作
KeyAscii = 0 '屏蔽掉默认的“滴”的声音
SendKeys "{tab}" '执行Tab键操作，焦点跳转到下一个控件
Case Else '其他的字符和键值均不响应
KeyAscii = 0
End Select
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -