实验一 实验二 实验三 实验四 实验五 实验六 实验七 实验八
实验九 实验十 实验十一 实验十二 实验十三 实验十四 实验十五
实验一 VB应用程序的创建
1、 屏幕上显示信息用一标签控件。
Private Sub Form_Load() ' 窗体的Load事件过程
Label1.Caption = "你好，Visual Basic系统"
Command1.Visible = False
Command2.Visible = False
End Sub
Private Sub Form_Click() ' 窗体的单击事件过程
Label1.Caption = "初一次见面，请多关照！"
Command1.Visible = True
Command2.Visible = True
End Sub
Private Sub Command1_Click() '“继续”按钮的单击事件过程
Label1.Caption = "你好，Visual Basic系统"
Command1.Visible = False
Command2.Visible = False
End Sub
Private Sub Command2_Click() '“结束”按钮的单击事件过程
End
End Sub
2、 略
3、 在实例二设计的界面上添加“求余”和“乘方”两个命令按钮。并编写如下代码：
Private Sub Command5_Click() '“求余”按钮的单击事件过程
Label1.Caption = "Mod"
Text3.Text = Str(Val(Text1.Text) Mod Val(Text2.Text))
End Sub
Private Sub Command6_Click() '“乘方”按钮的单击事件过程
Label1.Caption = "^"
Text3.Text = Str(Val(Text1.Text) ^ Val(Text2.Text))
End Sub
实验二 顺序结构程序设计
2—1 略
2—2
Private Sub Command1_Click()
Dim x%, y%
x = Int(90 * Rnd) + 10
y = Int(90 * Rnd) + 10
' Chr$(13) & Chr(10) 表示回车换行符
Text1.Text = Text1.Text & x & "+" & y & "="
& "( )" & Chr$(13) & Chr(10)
End Sub
2—3 略
2—4
Private Sub Command1_Click() '“放大”按钮的单击事件过程
Randomize
Text1.FontSize = Text1.FontSize * Int(Rnd * 5 + 1)
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub Command3_Click() '“还原”按钮的单击事件过程
Text1.FontSize = 9
Command1.Enabled = True
Command2.Enabled = True
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer) '去除空格，重新显示
If KeyAscii = 13 Then
Text1.Text = LTrim(RTrim(Text1.Text))
End If
End Sub
Private Sub Command2_Click() '“缩小”按钮的单击事件过程
Randomize
Text1.FontSize = Text1.FontSize / Int(Rnd * 5 + 1)
Command1.Enabled = True
Command2.Enabled = False
End Sub
实验三 选择结构程序设计
3—1：
Dim times As Integer ' 定义模块级变量，用来保存输入密码的次数
Private Sub Form_Load()
Text1.MaxLength = 6
Text1.PasswordChar = "*"
Text1 = ""
End Sub
Private Sub Command1_Click()
Dim st As String，sp As String
' 由系统日期构成密码字符串
sp = Right$(Str(Year(Date)), 2) & Trim(Str(Month(Date))) & Trim(Str(Day(Date)))
st = Text1
If Not IsNumeric(st) Then ' 如果不是数字字符
MsgBox "密码是数字字符", vbExclamation + vbOKOnly, "输入错误"
Text1 = "": Text1.SetFocus
ElseIf st = sp Then
MsgBox "欢迎进入本系统!", vbOKOnly + vbInformation, "通过验证"
Shell "C:\windows\NOTEPAD.EXE", 1
Else
times = times + 1
If times > 3 Then
MsgBox "你是非法用户", vbOKOnly, "输入错误"
End
End If
MsgBox "密码错误，请再试一次", vbExclamation, "输入错误"
Text1 = "": Text1.SetFocus
End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Call Command1_Click
End If
End Sub
3-2
Private Sub Command1_Click()
Dim rh&, m&, srh$, sm$
Randomize
rh = Int(Rnd * 9000000) + 1000000 ' 产生一个七位长整数
sm = InputBox$("请输入你要的号码，最多七位，且为数字")
srh = Str$(rh)
If srh = sm Then
Picture1.Print "特等奖"
ElseIf Right(srh, 6) = Right(sm, 6) Then
Picture1.Print "一等奖"
ElseIf Right(srh, 5) = Right(sm, 5) Then
Picture1.Print "二等奖"
ElseIf Right(srh, 4) = Right(sm, 4) Then
Picture1.Print "三等奖"
ElseIf Right(srh, 3) = Right(sm, 3) Then
Picture1.Print "四等奖"
ElseIf Right(srh, 2) = Right(sm, 2) Then
Picture1.Print "五等奖"
ElseIf Right(srh, 1) = Right(sm, 1) Then
Picture1.Print "六等奖"
Else
Picture1.Print "谢谢参与，祝下次好运"
End If
End Sub
3-3 略
3-4
Dim tb As Date, te As Date ' 定义模块级变量，tb表开始时间，te表示结束时间
Private Sub Command1_Click()
tb = time
Text1 = tb : Text2 = "" : Text3 = "" : Text4 = ""
End Sub
Private Sub Command2_Click()
Dim mon!, ttb&, tte&, tt&, hb&, he&, fb&, fe&, sb&,
se&
te = time : Text2 = te
he = Hour(te): fe = Minute(te): se = Second(te)
hb = Hour(tb): fb = Minute(tb): sb = Second(tb)
If he < hb Then he = he + 24 '如结束时间小于开始时间，则肯定结束时间已是第二天
ttb = hb * 3600 + fb * 60 + sb
tte = he * 3600 + fe * 60 + se
tt = tte - ttb
Text3 = Str(tt \ 3600) + "小时" + Str((tt Mod 3600) \ 60) + "分"
+ Str((tt Mod 3600) Mod 60) + "秒"
mon = 0.5
If tt > 180 Then
tt = tt - 180
mon = mon + (tt \ 60) * 0.15
If tt Mod 60 <> 0 Then mon = mon + 0.15 '不到一分钟按一分计算
End If
If Not (tb > 7 And tb < 19) Then ' 若开始计时是半价时段
mon = mon / 2
End If
Text4 = mon
End Sub
实验四 循环结构程序设计
4-1
Private Sub Form_Click()
Dim i%, j%, st$
For i = 1 To 7 ' 打印上半图形
st = Chr$(65 + i - 1)
Print Tab(10 - i);
For j = 1 To i
Print st; " ";
Next j
Print
Next i
For i = 6 To 1 Step –1 ' 打印下半图形
st = Chr$(65 + i - 1)
Print Tab(10 - i);
For j = 1 To i
Print st; " ";
Next j
Print
Next i
End Sub
4—2 略
4－3
Private Sub Form_Click()
Dim n%, n1%, n2%, i%, st$
st = "输入一个大于6的偶数" + Chr(13) + Chr(10) + "然后单击确定"
n = Val(InputBox(st, "输入框"))
For n1 = 3 To n \ 2
For i = 2 To n1 \ 2
If n1 Mod i = 0 Then GoTo nn ' 如果n1不是素数
Next i
n2 = n - n1
For i = 2 To n2 \ 2
If n2 Mod i = 0 Then GoTo nn ' 如果n2不是素数
Next i
Print n; "="; n1; "+"; n2 ' 打印输出
'Exit For
nn:
Next n1
End Sub
4-4
Private Sub Form_Click()
Dim a!, x1!, x0!
a = (InputBox("输入一个数A=？", "输入框"))
x1 = a / 3 '先给x1赋一初值,
Do
x0 = x1 '先给x1赋值给x0
x1 = 2 / 3 * x0 + a / (3 * x0 * x0) ' 通过迭代公式求得到一个新的值x1
Loop Until Abs(x1 - x0) < 0.000001
Print a; "的立方根是："; x1
End Sub
4—5 略
4—6
Private Sub Form_Click()
Dim i%, j%, k%, m%, n% '用i,j,k分别代表1分、2分、5分枚数
n = 0 'n代表取法总数
For i = 1 To 20
For j = 1 To 20
For k = 1 To 20
m = i + 2 * j + 5 * k '用m代表取出20枚硬币的总值
If m = 60 And i + j + k = 20 Then '当硬币数为20枚，且总值等60分，则输出
Print "1分:"; i, "2分:"; j, "5分:", k
n = n + 1
End If
Next k
Next j
Next i
Print "------------------------------------"
Print "总共有："; n; " 取法"
End Sub
4—7
Option Explicit
Private Sub Command1_Click()
Dim lw As Integer, s As String, i As Integer
Dim strInput As String, strWord As String
Dim nmax As Integer, maxWord As String
strInput = RTrim(txtInput.Text) '去除右端的空格
Do While Len(strInput) > 0 '当文本未处理完
lw = InStr(strInput, " ") '以空格为单词的分隔
If lw = 0 Then '文本中最后一个单词
strWord = strInput
strInput = ""
Else
strWord = Left(strInput, lw - 1) '当文本未处理完分离出一个单词
strInput = Mid(strInput, lw + 1) '取余下的文本待处理
End If
If nmax < Len(strWord) Then
nmax = Len(strWord)
maxWord = strWord
End If
strInput = RTrim(strInput)
Loop
txtSearch = maxWord
End Sub
Private Sub Command2_Click()
txtInput = ""
txtInput.SetFocus
End Sub
实验五 数组的应用
5-1
Option Base 1
'定义窗体级数组s用于存放字符串，窗体级变量用于统计字符串个数
Dim n%, s(100) As String
Private Sub Command1_Click() '冒泡法递减排序
Dim flag As Boolean
For i% = 1 To n - 1
flag = True
For j% = 1 To n - i
If s(j) < s(j + 1) Then
t$ = s(j) : s(j) = s(j + 1) : s(j + 1) = t
flag = False
End If
Next j
If flag Then Exit For
Next i
Picture1.Cls '清除图片框内容
For i = 1 To n
Picture1.Print s(i)
Next i
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then '按下回车键
n = n + 1 '字符串个数加1
s(n) = Text1.Text '把字符串存入数组
Picture1.Print s(n)
Text1.Text = ""
Text1.SetFocus
End If
End Sub
5-2
Dim a() As Integer ' 定义窗体级动态数组a
Const n = 10
Private Sub Form_Click()
Dim x%, p%
x = Val(InputBox("x="))
p = 1 ' 初始化变量p，p代表x要插入的位置
Do While x < a(p) And p <= n ' 确定x要插入的位置p
p = p + 1
Loop
ReDim Preserve a(1 To n + 1) ' 空出插入位置
For i = n To p Step -1
a(i + 1) = a(i)
Next i
a(p) = x ' 插入x
For i = 1 To n + 1
Print a(i);
Next i
End Sub
5-3 略
5-4 略
5-5 略
5-6
Option Base 1
Private Sub RandSort()
Dim p(20) As Integer
Dim n%,j%,k%,ix%
j = 1 ' 产生20个不相等的随机数
Do While j <= 20
k = Int(Rnd * 50) + 1
For n = 1 To j
If p(n) = k Then GoTo nnn
Next n
p(j) = k
j = j + 1
nnn:
Loop
For i=1 to 19 ' 选择法排序
ix=i
For j=i+1 to 20
IF p(ix)>p(j) Then ix=j
Next j
If ix<>i Then
k=p(ix): p(ix)=p(i) : p(i)=k
End if
Nexi i
For j = 1 To m
Print p(j)
If j mod 10 =0 Then Print ' 换行
Next j
End Sub
实验六 函数过程和子过程
6-1 略
6-2
程序界面设计及运行情况如下
在窗体模块程序代码：
Dim a(10) As Integer
Private Sub Command1_Click() '从键盘输入10个整数
Dim i As Integer
Picture1.Cls
Picture1.Print "初始值"
For i = 1 To 10
a(i) = Val(InputBox("a(" + Str(i) + ")="))
Picture1.Print a(i);
If i Mod 5 = 0 Then Picture1.Print
Next i
End Sub
Private Sub Command2_Click() '求最大数
Picture1.Print "最大数为:"; maxnum(a)
End Sub
Private Sub Command3_Click() '求平均值
Picture1.Print "平均值为:"; avenum(a)
End Sub
Private Sub Command4_Click() '排序
Dim i%
Call ordernum(a)
Picture1.Print "排序结果:"
For i = 1 To 10
Picture1.Print a(i);
If i Mod 5 = 0 Then Picture1.Print
Next i
End Sub
在标准模块程序代码：
Public Function maxnum(a() As Integer) As Integer '最大数函数
Dim Max%,i%
Max = a(LBound(a))
For i = LBound(a) + 1 To UBound(a)
If a(i) > Max Then Max = a(i)
Next i
maxnum = Max
End Function
Public Function avenum(a() As Integer) As Single '平均值函数
Dim s%,i%,
s = 0
For i = LBound(a) To UBound(a)
s = s + a(i)
Next i
avenum = s / (UBound(a) - LBound(a) + 1)
End Function
Public Sub ordernum(a() As Integer) '排序过程
Dim i%,j%,p%,t%
For i = LBound(a) To UBound(a) - 1
p = i
For j = i + 1 To UBound(a)
If a(j) < a(p) Then p = j
Next j
t = a(i): a(i) = a(p): a(p) = t
Next i
End Sub
6-3 略
6-4
'查找最长单词函数
Public Function maxlength(ByVal s As String) As String
Dim p%,Max%
s = Trim(s) ' 清除待查字符串的首尾空格
p = InStr(s, " ") ' 确定字符串中第一个空格的位置
Max$ = "" ' 假设为空串
Do While p <> 0
' 比较当前找到的最长单词与分解出的单词
If Len(Max) < p - 1 Then Max = Left(s, p - 1)
s = Trim(Mid(s, p)) ' 取子字符串
p = InStr(s, " ") ' 确定下一个空格的位置
Loop
' 比较当前找到的最长单词与字符串的剩余部分
If Len(Max) < Len(s) Then Max = s
maxlength = Max
End Function
6-5
Private Function s(n%, x!) As Single ' 函数过程
Dim i%, k%, t#, f#
f = 0#: k = x: t = 1#
For i = 2 To 2 * n Step 2
t = t * i * (i - 1)
f = f + k / t
k = k * x * x
Next i
s = f
End Function
Private Sub Form_Click() ' 窗体单击事件程序
Dim n%, x!
x = InputBox("x=")
n = InputBox("n=")
Print "s="; s(n, x)
End Sub
6-6 略
实验七 变量和过程的作用域
7-1
Private Sub Form_Click() ' 窗体的单击事件
Dim strin$, fd!
strIn = InputBox("输入一个二制数")
fd = TranBtoD(strIn) ' 调用函数
print "二进制数：" & strIn & "转换为十进制数是：" &fd
End Sub
Private Function TranBtoD(str$) As Single ' 二进制串转换成十进数的函数
Dim st1$, st2$
Dim numD!, i%, n%, k%, fg%
str = Trim(str)
st1 = "": st2 = ""
k = InStr(str, ".")
If k > 0 Then
st1 = Mid(str, 1, k - 1)
st2 = Mid(str, k + 1)
Else
st1 = str
End If
fg = 1
If Mid(st1, 1, 1) = "-" Then fg = -1
n = 0
For i = Len(st1) To 1 Step -1 '处理整数部分
numD = numD + Val(Mid(st1, i, 1)) * 2 ^ n
n = n + 1
Next i
For i = 1 To Len(st2) '处理小数部分
numD = numD + Val(Mid(st2, i, 1)) / 2 ^ i
Next i
TranBtoD = numD * fg
End Function
7—2
Dim a() As Integer, n% ' 定义窗体级变量
Private Sub Command1_Click() ' 显示数据
Dim i%
For i = 1 To n
Picture1.Print a(i); " ";
Next i
End Sub
Private Sub Command2_Click() '显示删除后的数据
Dim i%
Call DelSame(a()) ' 调用函数，删除相同数据
For i = 1 To UBound(a)
Picture2.Print a(i); " ";
Next i
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer) ' 输入数据存入数组中
If KeyAscii = 13 Then
n = n + 1
ReDim Preserve a(n) ' 保留原的元素值，重新定义数组大小
a(n) = Val(Text1)
Text1 = ""
End If
End Sub
Private Sub DelSame(a() As Integer) ' 删除相同数据函数
Dim i%, k%, J%
k = UBound(a)
i = 1
Do While i < k
J = i + 1
Do While J <= k
If a(i) = a(J) Then ' 如果有其它元素与a(i)相同
k = k - 1 ' 让元素个数减少一个
i = i - 1 ' 为让i不变，因为后面的i=i+1,以便能删除连续出现相同的数据
Exit Do
End If
J = J + 1
Loop
Do While J <= k ' 此循环是删除相同元数
a(J) = a(J + 1) '用后面的元素覆盖前面的元素
J = J + 1
Loop
i = i + 1
Loop
ReDim Preserve a(k) ' 删除数组的长度为k
End Sub
7-3
程序界面设计与7-2题基本相同，只是没有“输入数据”标签及其文本框，并添加一标准模块。将7-2题中的DelSame(a() As Integer)过程复制到标准模块，将Private改为
Public，再编写产生数组元素的过程。
Public Sub GetArry(a() As Integer, n As Integer, min As Integer, max As Integer)
ReDim a(1 To n)
Randomize
For i% = 1 To n
a(i) = Int(Rnd * (max - min + 1)) + min
Next i
End Sub
窗体模块程序代码为：
Option Base 1
Dim a() As Integer
Private Sub Command1_Click() '显示按钮单击事件过程
Call GetArry(a, 10, 1, 50)
Picture1.Cls
For i% = 1 To UBound(a)
Picture1.Print a(i);
Next i
End Sub
Private Sub Command2_Click() '删除按钮单击事件过程
Call DelSame(a)
Picture2.Cls
For i% = 1 To UBound(a)
Picture2.Print a(i);
Next i
End Sub
7-4 略
实验八 基本控件与多重窗体
8-1 程序中各控件设置与本实验操作实例一、二相同。
在密码窗口编写如下代码：
Option Base 1
Dim pass(4, 2) As String 定义二维数组用于保存用户名和密码
Private Sub cmdCancel_Click()
txtID.Text = ""
txtPass.Text = ""
txtID.SetFocus
End Sub
Private Sub cmdOk_Click()
Static n As Integer ' 记录输入次数
Dim flag As Boolean ' 判断是否为合法用户
If n < 2 Then ' 未超过3次，注意第1次时n为0
flag = False ' 假设为非法用户
For i% = 1 To 4 ' 在数组pass中查找
If txtID.Text = pass(i, 1) And txtPass.Text = pass(i, 2) Then
flag = True
Exit For
End If
Next i
If Not flag Then ' 非法用户
n = n + 1
MsgBox "密码错误", vbCritical + vbOKOnly, "密码检验"
cmdOk.Enabled = False
Else '合法用户
Unload frmPass 'frmPass.Hide
Load frmNotepad 'frmNotepad.Show
frmNotepad.Visible = True
End If
Else
MsgBox "密码错误三次，退出！", vbCritical + vbOKOnly, "密码检验"
End
End If
End Sub
Private Sub Form_Load() ' 初始化
txtID.Text = ""
txtPass.Text = ""
'初始化数组pass
pass(1, 1) = "111": pass(1, 2) = "aaa"
pass(2, 1) = "222": pass(2, 2) = "bbb"
pass(3, 1) = "333": pass(3, 2) = "ccc"
pass(4, 1) = "444": pass(4, 2) = "ddd"
End Sub
Private Sub txtID_Change()
cmdOk.Enabled = True
End Sub
Private Sub txtPass_Change()
cmdOk.Enabled = True
End Sub
8—2
Dim op1 As String ' 第一个运算数
Dim op As String ' 当前运算符
Private Sub cmdEqv_Click() ' 等号按钮的单击事件过程
If op <> "" Then '已按下运算符
op2 = txtInput.Text ' 当前输入为第二个运算数
'根据当前运算符进行相应运算
If op = "＋" Then op1 = Str(Val(op1) + Val(op2))
If op = "－" Then op1 = Str(Val(op1) - Val(op2))
If op = "×" Then op1 = Str(Val(op1) * Val(op2))
If op = "÷" And Val(op2) <> 0 Then op1 = Str(Val(op1) / Val(op2))
txtInput.Text = op1 '显示运算结果
op = "" '清空运算符
For i% = 0 To 3 '运算符按钮恢复有效
cmdOp(i).Enabled = True
Next i
End If
End Sub
Private Sub cmdNum_Click(Index As Integer) '数字按钮控件数组的单击事件过程
txtInput.Text = txtInput.Text + cmdNum(Index).Caption
End Sub
Private Sub cmdOnOff_Click() 'ON/OFF按钮的单击事件过程
Static flag As Boolean '是否已经按过
If Not flag Then '未按过
flag = True
txtInput.SetFocus
Else '按过
End
End If
End Sub
Private Sub cmdOp_Click(Index As Integer) '运算符按钮控件数组的单击事件过程
op1 = txtInput.Text '当前输入为第一个运算数
txtInput.Text = ""
txtInput.SetFocus
op = cmdOp(Index).Caption '记录当前运算符
For i% = 0 To 3 '使所有运算符按钮无效
cmdOp(i).Enabled = False
Next i
End Sub
8-3 略
8-4
' 设窗体名为frmNotepad，文件框名为txtNotepad
Private Sub Form_Load() '加载窗体时初始化文本框大小
txtNotepad.Left =0
txtNotepad.Top = 0
txtNotepad.Width = frmNotepad.ScaleWidth
txtNotepad.Height = frmNotepad.ScaleHeight
End Sub
Private Sub Form_Resize() '改变窗体大小调整文本框大小
Call Form_Load ' 调用Load事件过程，根据窗体大小重新设置文本框大小
End Sub
8—5 略
实验九 基本控件与自定义对话框
9—1
建立一工程，将实例一的窗体frmfont和实验八中的实frmNotepad例二窗体添加到工程，将frmfont窗体的cmdOk_click()和cmdCancel_clisk()事件改为，其它事件过程代码不变。
Private Sub cmdCancel_Click() ' “取消”按钮事件
Unload frmFont
frmNotepad.Show
End Sub
Private Sub cmdOk_Click() ' “确定”按钮事件
frmNotepad.txtNotepad.FontName = lstFontName.Text
frmNotepad.txtNotepad.FontBold = False
frmNotepad.txtNotepad.FontItalic = False
frmNotepad.txtNotepad.FontUnderline = False
frmNotepad.txtNotepad.FontStrikethru = False
If chkFontStyle(0).Value = 1 Then frmNotepad.txtNotepad.FontBold = True
If chkFontStyle(1).Value = 1 Then frmNotepad.txtNotepad.FontItalic = True
If chkFontStyle(2).Value = 1 Then frmNotepad.txtNotepad.FontUnderline = True
If chkFontStyle(3).Value = 1 Then frmNotepad.txtNotepad.FontStrikethru = True
If IsNumeric(Val(cboFontSize.Text)) And Val(cboFontSize.Text) > 0 Then
frmNotepad.txtNotepad.FontSize = Val(cboFontSize.Text)
Else
MsgBox "无效字号，请重新选择！", vbCritical + vbOKOnly, "字体"
End If
frmNotepad.txtNotepad.ForeColor = RGB(hsbFontColor(0).Value, hsbFontColor(1).Value,
hsbFontColor(2).Value)
If optNo.Value Then
frmNotepad.txtNotepad.BackColor = vbWhite
Else
frmNotepad.txtNotepad.BackColor = vbRed
End If
Unload frmFont
frmNotepad.Show
End Sub
9—2 略
9—3
Private Sub Form_Load() ' 初始化
Timer1.Interval = 100
Timer1.Enabled = True
HScroll1.Min = -Label1.Width
HScroll1.Max = Form1.Width
HScroll1.Value = HScroll1.Min
Label1.Left = 0
End Sub
Private Sub HScroll1_Change() ' 用滚动条值控制标签的水平位置
Label1.Left = HScroll1.Value
End Sub
Private Sub Timer1_Timer()
If Label1.Left < Form1.Width Then
Label1.Left = Label1.Left + 50
Else
Label1.Left = -Label1.Width
End If
If Label1.Left > -Label1.Width And Label1.Left < Form1.Width Then
HScroll1.Value = Label1.Left
End If
End Sub
9—4 略
9—5 略
9—6
Private Sub Check1_Click(Index As Integer)
Text1(Index) = ""
If Check1(Index).Value = 1 Then
Text1(Index).SetFocus
End If
End Sub
Private Sub Command1_Click()
Dim i As Integer
Dim sum As Long, n%
Dim title As String, price As Integer
sum = 0
For i = 0 To 4
Select Case i
Case 0
title = "电视机"
price = 3580
Case 1
title = "微波炉"
price = 660
Case 2
title = "电冰箱"
price = 1850
Case 3
title = "DVD"
price = 2880
Case 4
title = "分体空调"
price = 5500
End Select
If Check1(i).Value = 1 And Text1(i).Text <> "" Then
List1.AddItem title & " " & Text1(i).Text & "台"
sum = sum + Val(Text1(i)) * price
n = n + Val(Text1(i))
End If
Next i
If sum <> 0 Then
List1.AddItem "共计: " & n & "台 " & "合计金额:"
& sum & "元"
End If
End Sub
Private Sub Command2_Click()
List1.Clear
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If Chr(KeyAscii) > "9" Or Chr(KeyAscii) < "0" Then
KeyAscii = 0
End If
End Sub
实验十 键盘和鼠标事件
10—1
Private Sub Form_Click()
Dim oldsen As String, newsen As String
Dim char As String, lastchar As String
Dim n As Integer, i As Integer
oldsen = InputBox("请输入英文句子：")
n = Len(oldsen)
'以空格作为单词的界定，空格后的字母转换为大写字母
lastchar = " "
For i = 1 To n
char = Mid(oldsen, i, 1)
If lastchar = " " Then
char = UCase(char)
End If
newsen = newsen & char
lastchar = char
Next i
Print "输入:"; oldsen
Print "输出:"; newsen
End Sub
10—2 略
10—3
'文本框的KeyUp事件过程
Private Sub txtNotepad_KeyUp(KeyCode As Integer, Shift As Integer)
Dim strText As String ' 文本框内容
Static search As String ' 待查文本
Dim change As String ' 替换文本
Static where As Integer ' 插入点位置
strText = txtNotepad.Text
If KeyCode = vbKeyF And Shift = 2 Then ' 按下CTRL+F键
search = InputBox("请输入待查文本:") ' 指定待查文本
where = InStr(strText, search) ' 查找定位
If where > 0 Then '找到
'选中文本
txtNotepad.SelStart = where - 1
txtNotepad.SelLength = Len(search)
Else '未找到
MsgBox "对不起，未找到" + search + "！"
End If
End If
'按CTRL+N键且已输入待查文本
If KeyCode = vbKeyN And Shift = 2 And search <> "" Then
where = InStr(where + Len(search), strText, search) '继续定位
If where > 0 Then '找到
'选中文本
txtNotepad.SelStart = where - 1
txtNotepad.SelLength = Len(search)
Else '未找到
MsgBox "全文搜索完毕！"
End If
End If
'按CTRL+E键且已选中文本
If KeyCode = vbKeyE And (Shift And vbCtrlMask) > 0 And txtNotepad.SelText
<> "" Then
change = InputBox("请输入替换文本:")
txtNotepad.SelText = change
End If
End Sub
10-4 略
10-5 略
实验十一 菜单设计与通用对话框
11—1 程序界面如下：
各菜单的事件代码如下
Dim first As Boolean，flag As Boolean，fName As String
Private Sub Form_Load() '初始化窗体级变量
first = True : flag = True : fName = ""
End Sub
Private Sub Form_Unload(Cancel As Integer) ' 退初窗体时
mnuExit_Click
End Sub
Private Sub mnuExit_Click() ' 退出菜单项的单击事件过程
If Not flag Then
i = MsgBox("文件内容已修改，是否保存？", vbExclamation + vbYesNo, "保存文件")
If i = vbYes Then mnuSave_Click
End If
End
End Sub
Private Sub mnuOpen_Click() ' 打开菜单项的单击事件过程
'激活对话框前初始化设置相关属性，激活对话框后将无法在代码中设置器属性。
CommonDialog1.FileName = "*.txt" ' 初始化文件名
CommonDialog1.InitDir = "C:\" ' 初始化路径
CommonDialog1.Filter = "Word文档|*.doc|文本文件|*.txt|所有文件|*.*" '设置文件类型列表框内容
CommonDialog1.FilterIndex = 2 ' 设置默认文件类型
CommonDialog1.Action = 1 ' 激活打开对话框
txtNotepad.Text = "" ' 清除文本框中原有内容
If CommonDialog1.FileTitle <> "" Then ' 选定文件后执行下列操作
Dim InputData As String ' 保存文件中每行内容
Open CommonDialog1.FileName For Input As 1 '打开文件，准备读文件。
Do While Not EOF(1)
Line Input #1, InputData ' 每次读一行
' 将读出内容连接在文本框已有文本之后并回车换行
txtNotepad.Text = txtNotepad.Text + InputData + vbCrLf
Loop
Close #1
first = False
flag = True
fName = CommonDialog1.FileName
End If
End Sub
Private Sub mnuSave_Click() '保存文件
If first Then
mnuSaveAs_Click
Else
Open fName For Output As #1
Print #1, txtNotepad.Text
Close #1
End If
End Sub
Private Sub mnuSaveAs_Click() '另存为菜单项的单击事件过程
CommonDialog1.FileName = "文本1.txt" '设置缺省文件名
CommonDialog1.DefaultExt = "txt" '设置缺省扩展名
CommonDialog1.InitDir = "C:\"
CommonDialog1.Filter = "Word文档|*.doc|文本文件|*.txt|所有文件|*.*"
CommonDialog1.FilterIndex = 2
CommonDialog1.CancelError = True '选取“取消”按钮时出错
On Error GoTo errCancel '出错跳转至行标签errCancel
CommonDialog1.ShowSave '激活另存为对话框
Open CommonDialog1.FileName For Output As #1 '打开文件，准备写入。
Print #1, txtNotepad.Text
Close #1
first = False
flag = True
fName = CommonDialog1.FileName
errCancel: ' 行标签
End Sub
Private Sub txtNotepad_Change() ' 当文本内容发生改变时
flag = False
End Sub
12—2
' 在“记事本”窗口中，“查找”和“替换”菜单事件如下：
Private Sub mnuFind_Click()
Form2.Show
End Sub
Private Sub mnuRepl_Click()
Form2.Show
End Sub
' 在“查找和替换”窗体中各命令按钮事件代码为：
Dim find As Boolean '定义窗体级变量
Private Sub cmdCancel_Click() ' 取消
Form2.Hide
End Sub
Private Sub cmdRepl_Click() ' 替换
If find Then Form1.txtNotepad.SelText = txtChange.Text
End Sub
Private Sub cmdReplAll_Click() ' 全部替换
Dim p As Integer
Dim st As String, ln As Integer
st = Trim(txtFind.Text)
ln = Len(st)
p = InStr(Form1.txtNotepad.Text, st)
Do While p <> 0
Form1.txtNotepad.SelStart = p - 1
Form1.txtNotepad.SelLength = ln
Form1.txtNotepad.SelText = txtChange.Text
p = InStr(p + Len(txtChange.Text) - 1, Form1.txtNotepad.Text, st)
Loop
End Sub
Private Sub cmdNext_Click() ' 查找下一处
Static p As Integer
Dim st As String, ln As Integer
st = Trim(txtFind.Text)
ln = Len(st)
p = InStr(p + 1, Form1.txtNotepad.Text, st)
If p > 0 Then
Form1.txtNotepad.SetFocus
Form1.txtNotepad.SelStart = p - 1
Form1.txtNotepad.SelLength = ln
find = True
Else
find = False
MsgBox "没有找到" + st, vbInformation + vbOKOnly, "查找和替换"
End If
End Sub
Private Sub Form_Load() ' 初始化窗体变量
find = False '没找到
End Sub
12—3 略
12—4 略
12—5 略
实验十二 多文档界面与工具栏设计
12—1 略
12—2 参考12—3题
12—3 程序运行界面如下
在主文档窗体中的各事件代码：
Private Sub MDIForm_Load() ' 初始化
Form1.Show
Form1.Left = 0
Form1.Top = 0
Form1.Width = MDIForm1.ScaleWidth
Form1.Height = MDIForm1.ScaleHeight
Form2.Show
Form2.Left = 0
Form2.Top = 0
Form2.Width = MDIForm1.ScaleWidth
Form2.Height = MDIForm1.ScaleHeight
mnuCascade_Click '调用"层迭"菜单单击事件,使两子窗体层迭
End Sub
Private Sub mnuArrange_Click() '窗体层迭
MDIForm1.Arrange vbArrangeIcons
End Sub
Private Sub mnuCascade_Click() '窗体层迭
MDIForm1.Arrange vbCascade
End Sub
Private Sub mnuTile_Click() '窗体平辅
MDIForm1.Arrange vbTileHorizontal
End Sub
Private Sub mnuCopy_Click() '复制
Clipboard.SetText MDIForm1.ActiveForm.Text1.SelText
End Sub
Private Sub mnuCut_Click() '剪切
Clipboard.SetText MDIForm1.ActiveForm.Text1.SelText
MDIForm1.ActiveForm.Text1.SelText = ""
End Sub
Private Sub mnuPaste_Click() '粘贴
MDIForm1.ActiveForm.Text1.SelText = Clipboard.GetText
End Sub
Private Sub mnuNew_Click() ' 新建子文档窗体
Static n As Integer
Dim newForm As New Form1
n = n + 1
newForm.Caption = "New Form" & n
newForm.Show
End Sub
子文档一（Form1）中的事件代码：
Private Sub Form_Load()
Text1.Left = 0
Text1.Top = 0
Text1.Width = Form1.ScaleWidth
Text1.Height = Form1.ScaleHeight
End Sub
子文档二（Form2）中的事件代码：
Private Sub Form_Load()
Text1.Left = 0
Text1.Top = 0
Text1.Width = Form2.ScaleWidth
Text1.Height = Form2.ScaleHeight
End Sub
12—4 略
实验十三 文件操作
13—1
Dim sfname As String, dfname As String ' 定义窗体级变量，代表源文件名和目标文件保
Private Sub Cmdcopy_Click() ' 文件复制
If Right(Dir1.Path, 1) = "\" Then
sfname = Dir1.Path & File1.FileName
Else
sfname Dir1.Path & "\" & File1.FileName
End If
If Right(Dir2.Path, 1) = "\" Then
dfname = Dir2.Path & File2.FileName
Else
dfname Dir2.Path & "\" & File2.FileName
End If
FileCopy sfname, dfname
End Sub
Private Sub Cmdend_Click() ' 结束程序
End
End Sub
Private Sub Cmdnew_Click() ' 新建文件夹
Dim newname As String
newname = InputBox("请输入新建文件夹名（全路径）：", "新建文件夹")
If Right(Dir2.Path, 1) = "\" Then
MkDir Dir2.Path & newname
Else
MkDir Dir2.Path & "\" & newname
End If
End Sub
Private Sub Dir1_Change() ' 当目录改变后，使文件列表1框同步
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change() ' 当驱动器1改变后，使目录列表框1同步
Dir1.Path = Drive1.Drive
End Sub
Private Sub Drive2_Change()夹 ' 当驱动器2改变后，使目录列表框2同步
Dir2.Path = Drive2.Drive
End Sub
13-2 略
13-3 略
13-4
Sub Drive1_Change() ' 当驱动器1改变后，使目录列表框1同步
Dir1.Path = Drive1.Drive
End Sub
Sub dir1_Change() ' 当目录改变后，使文件列表1框同步
File1.Path = Dir1.Path
End Sub
Private Sub File1_Click() ' 将选中的文件显示在文本Text1中
Dim st As String
Text1.Text = ""
If Right(Dir1.Path, 1) = "\" Then
Open Dir1.Path & File1.FileName For Input As #1
Else
Open Dir1.Path & "\" & File1.FileName For Input As #1
End If
Do While Not EOF(1)
Line Input #1, st
Text1.Text = Text1.Text + st + Chr(13) + Chr(10)
Loop
Close #1
End Sub
Sub Form_Load() ' 初始化组合列表框
Dim Item As String
Item = "所有文件(*.*)"
cboType.AddItem Item + Space(20 - Len(Item)) + "*.*"
Item = "窗体文件(*.Frm)"
cboType.AddItem Item + Space(20 - Len(Item)) + "*.Frm"
Item = "文本文件(*.Txt)"
cboType.AddItem Item + Space(20 - Len(Item)) + "*.Txt"
cboType.ListIndex = 2
End Sub
Sub cboType_Click() ' 限定文件列表框中显示文件的类型
File1.Pattern = Mid(cboType.Text, 21)
End Sub
实验十四 图形操作
14-1 略
14-2
Private Sub Command1_Click() '选择绘笔颜色
CommonDialog1.Action = 3
Picture1.ForeColor = CommonDialog1.Color
End Sub
Private Sub Command2_Click() '清除
Picture1.Cls
End Sub
' 当鼠标按下键记录下当前坐标
Private Sub Picture1_MouseDown(Button%, Shift %, X As Single, Y As Single)
Picture1.CurrentX = X
Picture1.CurrentY = Y
End Sub
' 当鼠标左键按下并移动时画线
Private Sub Picture1_MouseMove(Button%, Shift%, X As Single, Y As Single)
If Option1.Value = True Then
Picture1.DrawWidth = 1
End If
If Option2.Value = True Then
Picture1.DrawWidth = 5
End If
If Button = 1 Then
Picture1.Line -(X, Y)
End If
End Sub
14-3 略
14-4
Private Sub File1_Click() ' 在文件列表框中选中图片文件
If Right(File1.Path, 1) <> "\" Then '图片文件不在根目录
Picture2.Picture = LoadPicture(File1.Path & "\" & File1.FileName)
Else
Picture2.Picture = LoadPicture(File1.Path & File1.FileName)
End If
Picture2.Left = 0
Picture2.Top = 0
HScroll1.Value = 0
VScroll1.Value = 0
If Picture2.Height > Picture1.Height Then '设置垂直滚动条
VScroll1.Enabled = True
VScroll1.Min = 0
VScroll1.Max = Picture2.Height - Picture1.Height
Else
VScroll1.Enabled = False
End If
If Picture2.Width > Picture1.Width Then '设置水平滚动条
HScroll1.Enabled = True
HScroll1.Min = 0
HScroll1.Max = Picture2.Width - Picture1.Width
Else
HScroll1.Enabled = False
End If
End Sub
14-5 略
实验十五 程序调试和出错处理
15—1
Option Base 1
'定义模块级变量和数组。
Dim MyYear As Integer, MyMonth As Integer, MyDay As Integer
Dim DayTab(1 To 12) As Integer ' 使月份与数组下标对应
' 计算总天数，将每月的天数累加
Private Function sumday(ByVal month As Integer, ByVal day As Integer)
Dim i As Integer, days As Integer
For i = 1 To month - 1
days = days + DayTab(i) 'Daytab()数组为每月天数
Next i
sumday = days
End Function
Private Function flag(ByVal year As Integer) As Boolean ' 判断该年是否是闰年
Dim yes As Boolean
If (year Mod 4 = 0) And (year Mod 100 <> 0) Or (year Mod 400 = 0) Then
yes = True
End If
flag = yes
End Function
Private Sub Cmbday_Click() ' 选择日期
MyDay = Val(Cmbday.Text)
End Sub
Private Sub cmbMonth_Click() ' 选择月份
MyMonth = Val(Cmbmonth.Text)
End Sub
Private Sub Cmdrestart_Click()
Txtyear.Text = ""
Txtday.Text = ""
Cmbmonth.Text = ""
Cmbday.Text = ""
Txtyear.SetFocus
End Sub
Private Sub Cmdcount_Click() ' 计算天数
Dim days As Integer
MyMonth = Val(Cmbmonth.Text)
MyDay = Val(Cmbday.Text)
days = sumday(MyMonth, MyDay)
days = days + MyDay
If flag(MyYear) And MyMonth >= 3 Then
days = days + 1
End If
Txtday.Text = days
End Sub
Private Sub Form_Load()
'设置每月的天数
Dim i As Integer
DayTab(1) = 31: DayTab(2) = 28: DayTab(3) = 31
DayTab(4) = 30: DayTab(5) = 31: DayTab(6) = 30
DayTab(7) = 31: DayTab(8) = 31: DayTab(9) = 30
DayTab(10) = 31: DayTab(11) = 30: DayTab(12) = 31
MyMonth = 1
MyDay = 1
For i = 1 To 31 '置日期1-31天
Cmbday.AddItem i
Next i
For i = 1 To 12 '置1-12月份
Cmbmonth.AddItem i
Next i
End Sub
Private Sub Txtyear_LostFocus() ' 判断输入年份是否有效
If Val(Txtyear.Text) > 0 And IsNumeric(Txtyear.Text) Then
MyYear = Val(Txtyear.Text)
Else
MsgBox "年份出错！"
Txtyear.SetFocus
End If
End Sub