vb源代码参考资料：源代码

第3章课前体验
Private Sub Form_Click()
For i = 1 To 10
For j = 1 To i
Print "* ";
Next j
Print
Next i
End Sub
【例3-1】
Private Sub Form_Click()
c1$ = Chr$(13) + Chr$(10)
msg1$ = "请输入您的名字,"
msg2$ = "输入后按回车键"
msg3$ = "或单击“确定”按钮"
msg$ = msg1$ + c1$ + msg2$ + c1$ + msg3$
name$ = InputBox(msg$,"InputBox 函数示例","张三")
Print name$
End Sub
【例3-2】
Private Sub Form_Click()
Msg1$=”Are you Continue to?”
msg2$=”Operation Dialog Box”
r=MsgBox(msg1$,34,msg2$)
Print r
End Sub
【例3-3】编写程序，用MsgBox函数判断是否继续执行。
Private Sub Form_Click()
msg$ = "请确认此数据是否正确"
Title$ = "数据检查对话框"
x = MsgBox(msg$,19,Title$)
If x = 6 Then
Print x * x
ElseIf x = 7 Then
Print "请重新输入"
End If
End Sub
【例3-5】
Private Sub Form_Click()
Print,Print
FontName = "隶书"
FontSize = 16
Print " 姓名"; Tab(8); "年龄"; Tab(16); "职务";
Print Tab(24); "单位"; Tab(32); "籍贯"
Print
Print "吴大明"; Tab(8); 25; Tab(16); "职员"; Tab(24); "人事科"; Tab(32); "北京"
Print "吴大明"; Tab(8); 25; Tab(16); "职员"; Tab(24); "人事科"; Tab(32); "北京"
End Sub
【例3-6】
Private Sub Form_Click()
X = InputBox("请输入成绩","学生成绩录入","00")
Print x
End Sub
【例3-7】
Private Sub Form_Click()
Dim x As Single,y As Single
x=InputBox(“请输入x的值”)
If x>0 Then y=1 ElseIf x=0 Then y=0 Else y=-1
Print,x=”; x,”y=” ; y
End Sub
【例3-8】
Private Sub Form_Click()
Dim msg,UserInput
msg = "请输入一个字母或0～9之间的数字."
UserInput = InputBox(msg) ‘输入一个字母或数字
If Not IsNumeric(UserInput) Then ‘判断是否是数字
If Len(UserInput) = 1 Then ‘不是数字时，判断输入的字符串长度是否为1
Select Case Asc(UserInput) ‘判断输入字母的ASCII码值
Case 60 To 90 '在60-90之间为大写字母
msg = "你输入的是一个大写字母'"
msg = msg & Chr(Asc(UserInput)) & "'。"
Case 97 To 122 '小写字母
msg = "你输入的是一个小写字母'"
msg = msg & Chr(Asc(UserInput)) & "'。"
Case Else
msg = "你没有输入字母或数字."
End Select
End If
Else
Select Case Val(UserInput) '将输入的数值型字符转换为数值
Case 1,3,5,7,9 '如果是奇数
msg = UserInput & " 是一个奇数。"
Case 0,2,4,6,8 '如果是偶数
msg = UserInput & " 是一个偶数。"
Case Else '出界
msg = "你输入的数字不在0～9范围内"
End Select
End If
MsgBox msg
End Sub
【例3-8】
Private Sub Form_Click()
Dim msg,UserInput
msg = "请输入一个字母或0～9之间的数字."
UserInput = InputBox(msg) ‘输入一个字母或数字
If Not IsNumeric(UserInput) Then ‘判断是否是数字
If Len(UserInput) = 1 Then ‘不是数字时，判断输入的字符串长度是否为1
Select Case Asc(UserInput) ‘判断输入字母的ASCII码值
Case 60 To 90 '在60-90之间为大写字母
msg = "你输入的是一个大写字母'"
msg = msg & Chr(Asc(UserInput)) & "'。"
Case 97 To 122 '小写字母
msg = "你输入的是一个小写字母'"
msg = msg & Chr(Asc(UserInput)) & "'。"
Case Else
msg = "你没有输入字母或数字."
End Select
End If
Else
Select Case Val(UserInput) '将输入的数值型字符转换为数值
Case 1,3,5,7,9 '如果是奇数
msg = UserInput & " 是一个奇数。"
Case 0,2,4,6,8 '如果是偶数
msg = UserInput & " 是一个偶数。"
Case Else '出界
msg = "你输入的数字不在0～9范围内"
End Select
End If
MsgBox msg
End Sub
【例3-10】
Sub Form_Click()
Dim N As Integer
n = InputBox("Enter N:") ‘输入N的值
k = 1
For i = 1 To N ‘循环N次，计算出N！
k = k * I
Next i
Print N;”!=”;k ‘数据输出
End Sub
【例3-12】
Dim S,N
S = 0,N = 0
Do While S <= 100
N = N + 1
S = S + N
Loop
Print S,N
【例3-13】
Private Sub Form_Click()
Dim char As String
Count = 0
char = InputBox("请输入一个字符")
While char <> "?"
Count = Count + 1
char = InputBox$("请输入一个字符")
Wend
Print "输入的字符数是:"; Count
End Sub
【例3-14】
Private Sub Form_Click()
Print " *";
For i = 1 To 9
Print Tab(i * 6); i;
Next i
Print
For j = 1 To 9
Print j;
For k = 1 To j
Print Tab(k * 6); j * k; " ";
Next k
Print
Next j
End Sub
第4章课前体验
（1）假定用来输入数学成绩的文本框名称为Text1，该文本框的LostFocus事件过程如下：
Private Sub Text1_LostFocus()
If Val(Text1.Text) < 0 Or Val(Text1.Text) > 100 Then
Text1.Text = ""
Text1.SetFocus
End If
End Sub
（2）其他文本框的LostFocus事件类似。
（3）假定按钮名称为Command1，该按钮的Click事件过程如下：
Private Sub Command1_Click()
If Check1.Value = 1 Then Sum = Sum + Val(Text1.Text)
If Check2.Value = 1 Then Sum = Sum + Val(Text2.Text)
If Check3.Value = 1 Then Sum = Sum + Val(Text3.Text)
If Check4.Value = 1 Then Sum = Sum + Val(Text4.Text)
If Check5.Value = 1 Then Sum = Sum + Val(Text5.Text)
Text6.Text = Sum
End Sub
【例4-1】
Private Sub Command1_Click() ‘在其单击事件中编程
For i = 1 To 6 ‘外循环，控制输出几行
For j = 1 To i ‘内循环，控制输出几列
Print " * ";
Next j
Print ‘换行
Next i
End Sub
【例4-2】
Private Sub Text1_Change()
Text2.Text = LCase(Text1.Text)
Text3.Text = UCase(Text1.Text)
End Sub
【例4-3】
Private Sub Check1_Click()
Text1.FontUnderline = Not Text1.FontUnderline
End Sub
Private Sub Check2_Click()
Text1.FontItalic = Not Text1.FontItalic
End Sub
Private Sub Option1_Click()
Text1.Font = "黑体"
End Sub
Private Sub Option2_Click()
Text1.Font = "宋体"
End Sub
【例4-4】
Private Sub Command1_Click()
If Option1 Then
Text1.FontName = "宋体"
Else
Text1.FontName = "黑体"
End If
If Option3 Then
Text1.FontSize = 8
Else
Text1.FontSize = 10
End If
End Sub
Private Sub Command2_Click()
End
End Sub
【例4-5】
Private Sub Form_Load()
‘在窗体的Load事件中输入列表框的各个项目
lstBooks.AddItem "计算机应用基础"
lstBooks.AddItem "操作系统"
lstBooks.AddItem "数据结构"
lstBooks.AddItem "网络技术基础"
End Sub
Private Sub cmdAdd_Click()
‘单击添加命令按钮时将文本框中输入的内容添加到列表框中
lstBooks.AddItem txtItem
txtItem = ""
End Sub
Private Sub cmdDelete_Click()
‘删除列表框中选中的项目
lstBooks.RemoveItem lstBooks.ListIndex
End Sub
Private Sub cmdModify_Click()
‘所选项目显示在文本框中，等待修改
txtItem.Text = lstBooks.Text
cmdAdd.Enabled = False
cmdDelete.Enabled = False
cmdModify.Enabled = False
cmdModify_OK.Enabled = True
End Sub
Private Sub cmdModify_OK_Click()
‘所选项目显示在文本框中修改完成后，按下修改确定按钮，更新列表框内容
lstBooks.List(lstBooks.ListIndex) = txtItem
cmdModify_OK.Enabled = True
cmdAdd.Enabled = True
cmdDelete.Enabled = True
cmdModify.Enabled = True
txtItem = ""
End Sub
【例4-6】
Private Sub Form_Click()
Picture3.Picture=Picture1.Picture
Picture1.Picture=Picture2.Picture
Picture2.Picture=Picture3.Picture
Pciture3.Picture=LoadPicture() ‘把第3个图片框设置为空
End sub
【例4-7】
Private Sub HScroll1_Change()
Text1.Text = HScroll1.Value
End Sub
【例4-8】
Private Timer1_Timer()
Labe1.Caption=Time$
End Sub
实训
Private Sub Command1_Click()
Debug.Print "姓名:"; Text1.Text
Debug.Print "出生年月:"; Text2.Text
Debug.Print "籍贯:"; Text3.Text
If Option1.Value Then Debug.Print "性别:"; "男"
If Option2.Value Then Debug.Print "性别:"; "女"
Debug.Print "民族:"; Combo1.Text
If Check1.Value = 1 Then Debug.Print "健康" Else Debug.Print "不健康"
Debug.Print "职称:"; Combo3.Text
Debug.Print "工资:"; Text4.Text
Debug.Print "外语熟练程度"; HScroll1.Value
Debug.Print "简历:"; Text5.Text
End Sub
第5章课前体验
Private Sub Command6_Click()
Const n = 10 ‘定义常量n的值为10
Max = 0,K = 0 ‘最高分及所在位置赋初值
For i = 1 To n
b(i) = InputBox("请输入第"& i &"个同学的成绩",求最高分) ‘输入成绩
If b(i) > Max Then
Max = b(i)
K = I ‘将第i个成绩与最高分Max相比，如果比最高分高，则保存起来
End If
Next i
Print"最高分是第"& K &"个同学，其成绩是："& Max
End Sub
【例5-1】
Option Base 1
Private Sub Command1_Click()
Dim a(3) As Integer
a(1) = 1,a(2) = 3,a(3) = 5
Print a(1)
Print a(2)
Print a(3)
End Sub
【例5-2】
For i=1 To 10
b(i) = InputBox("请输入第" & i & "个数")
Next i
【例5-3】
For i=1 To 2
For j=1 To 2
b(i,j) = i+j
Next j
Next i
【例5-4】
Dim S(3，2) As Integer
程序如下：
For i = 0 To 3
Print Tab(5); ‘输出位置定位
For j = 0 To 2
S(i,j) = i * 2 + j ‘给各元素赋值
Print S(i,j);
Next j
Print ‘换行
Next i
【例5-5】
Private Sub Form_Click()
Dim s(5) As Integer '定义数组S
Const n = 5
For i = 1 To n
s(i) = Val(InputBox("请输入第" & LTrim$(Str$(i)) & "个数",数据排序))
‘输入n个数，转换成数值后保存在数组中。
Next i
For i = 1 To n-1 ‘进行n-1趟比较
Max = I ‘对第i遍比较时，初始假定第i个元素最小。
For j = i + 1 To n ‘在数组i～n个元素中选最小元素
If s(j) < s(Max) Then Max = j
Next j
t = s(i)
s(i) = s(Max)
s(Max) = t ‘i～n个元素中选出的最小元素与第i个元素交换
Next i
For i = 1 To 5
Print s(i)
Next i
End Sub
【例5-6】
Dim b() As Integer
Private Sub Form_Click()
ReDim b(2)
For i = 0 To 2
b(i) = i
Next i
ReDim Preserve b(3)
b(3) = 7
For i = 0 To 3
Print b(i);
Next i
End Sub
【例5-7】
Dim a(8,8) As Integer '定义一个二维数组
Private Sub Form_Click()
‘下面的二层循环语句给数组赋值
For i = 1 To 8
For j = 1 To i
If i = 1 Or j = 1 Then
a(i,j) = 1 '数组中每一行第一个，最后一个数均为1
Else
a(i,j) = a(i - 1,j - 1) + a(i - 1,j)
'数组中其余数据等于它上一行的相邻两列之和
End If
Next j
Next i
'下面的二层循环语句将数组中的值打印出来
For i = 1 To 8
Print Tab(20 - 2 * i); '定位打印位置
For j = 1 To i
If a(i,j) < 10 Then '将数组中的值转换成长度为3的字符串，可使打印数据整齐
s = " " + Str(a(i,j)) + " "
ElseIf a(i,j) < 100 Then
s = " " + Str(a(i,j))
End If
Print s;
Next j
Print '换行
Next i
End Sub
【例5-8】
Private Sub Option1_Click(Index As Integer)
Select Case Index
Case 0
Label1.ForeColor = RGB(255,0,0)
Case 1
Label1.ForeColor = RGB(0,255,0)
Case 2
Label1.ForeColor = RGB(255,255,0)
End Select
End Sub
实训
Option Base 1 ‘定义数组下标从1开始
Dim arr() ‘定义动态数组arr
Private Sub Form_Click()
n = Val(InputBox("请输入矩阵的行数")) ‘输入矩阵行数
m = Val(InputBox("请输入矩阵的列数")) ‘输入矩阵列数
ReDim arr(n,m) ‘重定义数组arr为n行m列的二维数组
‘下列程序段为数组输入数据
For i = 1 To n
For j = 1 To m
arr(i,j) = Val(InputBox("请输入矩阵第" & i & "行第" & j & "列的数据"))
Next j
Next i
‘下列程序段在数组中找出最大值及所在位置
row = 1,col = 1
For i = 1 To n
For j = 1 To m
If arr(i,j) > arr(row,col) Then
row = i,col = j
End If
Next j
Next i
‘下列程序段输出矩阵及最大值及所在位置
Print "您输入的矩阵是："
Print
For i = 1 To n
Print Tab(8)； ‘打印位置定位
For j = 1 To m
Print arr(i,j);
Next j
Print ‘换行
Next i
Print
Print "矩阵中最大值为：";arr(row,col); "其位置在第" & row & "行" & col & "列"
End Sub
第6章课前体验
（2）编写窗体装载事件过程：
Private Sub Form_Load()
For I = 0 To 100
List1.AddItem i
Next i
End Sub
（3）使用“添加过程”对话框创建出判断成绩等级的过程
Public Sub DengJi(a As Integer)
Select Case a
Case 0 To 59
Label1.Caption = "不及格"
Case 60 To 69
Label1.Caption = "及格"
Case 70 To 79
Label1.Caption = "中等"
Case 80 To 89
Label1.Caption = "良好"
Case 90 To 100
Label1.Caption = "优秀"
End Select
End Sub
4）编写列表框单击Click事件过程：
Private Sub List1_Click()
Dim n As Integer
N = Val(List1.Text)
Call DengJi(n) '调用判断成绩等级的过程
End Sub
（5）编写命令按钮单击Click事件过程：
Private Sub Command1_Click()
End
End Sub
【例6-1】
Private Sub oushu(x As Integer,msg As Boolean)
If x Mod 2 = 0 Then
Msg = True
Else
Msg = False
End If
End Sub
【例6-2】
Public Function Rect(a As Double,b As Double)As Double
Rect = a * b
End Function
【例6-3】
（2）在窗体代码窗口中编写pingjun过程：
Sub pingjun(a As Integer,b As Integer,c As Integer)
C = (a+b)/2
End Sub
（3）编写命令按钮1的单击事件过程：
Private Sub Command1_Click()
Dim x As Integer,y As Integer,z As Integer
X = Val(Text1.Text)
Y = Val(Text2.Text)
Call pingjun(x,y,z) '或pingjun x,y,z
Text3.Text = Str(z)
End Sub
【例6-4】
（2）把判断奇偶性的函数过程jo的程序代码输入到窗体代码窗口中。
Function jo(x As Integer)As String
If x Mod 2 = 0 Then
Jo = "偶数"
Else
Jo = "奇数"
End If
End Function
（3）编写命令按钮1的单击事件过程：
Private Sub Command1_Click()
Dim n As Integer,w As String
n=Val(Text1.Text)
w = jo(n)
Label1.Caption=Text1.Text &"是"& w &"！"
End Sub
【例6-5】
（2）编写参数按地址传递次的过程Swap1：
Sub Swap1(x As String,y As String)
Dim t As String
T = x：x = y：y = t
End Sub
（3）编写命令按钮单击事件过程如下：
Private Sub Command1_Click()
Dim a As String,b As String
A = Text1.Text
B = Text2.Text
Form1.Caption = "按地址传递"
Swap1 a,b
Text1.Text = a
Text2.Text = b
End Sub
【例6-7】
（2）求任意一维数组中各元素之积的函数如下：
Function tt(a() As Integer)As Long '函数的形参是数组
Dim t#,i%
T = 1
For I = LBound(a) To UBound(a) '求数组的下界和上界
T = t * a(i)
Next i
Tt = t
End Function
（3）求任意一维数组中各元素之和的函数如下：
Function ss(b() As Integer)As Long '函数的形参是数组
Dim t#,i%
S = 0
For I = LBound(b) To UBound(b) '求数组的下界和上界
S = s+b(i)
Next i
Ss = s
End Function
（4）编写命令按钮单击事件过程，如下：
Private Sub Command1_Click()
Dim a(1 To 5)As Integer
Dim b(2 To 10)As Integer
Dim i As Integer,t1 As Long,s1 As Long
For I = 1 To 5 '给数组赋值
a(i) = i + 3
Next i
t1 = tt(a()) '调用函数
Print"第一个数组各元素之积t1="; t1
For I = 2 To 10
b(i) = i * 2
Next i
s1 = ss(b())
Print"第二个数组各元素之和s1="; s1
End Sub
【例6-8】
（1）先定义一个具有可选参数的函数过程sum，用来进行3个数的加法运算。
Private Function sum(x As Integer,Optional y As Integer,_
Optional z As Integer=3)As Integer
Sum = x + y + z
End Function
（2）编写窗体的单击事件过程，如下：
Private Sub Form_Click()
Print"sum(1) = 1 + 0 + 3 = ";sum(1) '省略两个参数
Print"sum(1,2) = 1 + 2 + 3 = ";sum(1,2) '省略第3个参数
Print"sum(1,,8) = 1 + 0 + 8 = ";sum(1,,8) '省略第2个参数
Print"sum(1,4,8) = 1 + 4 + 8 =";sum(1,4,8) '不省略参数
End Sub
【例6-9】
（1）先定义一个具有可变参数的函数过程MySum，如下：
Function MySum(ParamArray VA()) As Integer '声明为可变参数
Dim i As Integer
Dim Sum As Integer
Sum = 0
For i=LBound(VA) To UBound(VA) '得到数组的大小，并进行循环
Sum = Sum+VA(i)
Next
MySum = Sum
End Function
（2）编写窗体的单击事件过程，如下：
Private Sub Form_Click()
Dim s As Integer
Print
Print Tab(2); "使用3个实参：";
S = MySum(2,4,6) ' 可以使用任意多个实参来调用
Print "MySum(2,4,6)="; s
Print
Print Tab(2); "使用5个实参：";
S = MySum(1,2,3,4,5)
Print "MySum(1,2,3,4,5)=";s
End Sub
【例6-10】
（1）定义具有窗体参数的过程，如下：
Private Sub BiaoTi(fm As Form) 'fm为窗体对象参数
Text1.Text = "窗体的标题是"& fm.Caption
End Sub
调用过程BiaoTi会改变窗体对象fm中的文本框Text1的文本。
（2）定义具有控件对象参数的过程，如下：
Private Sub KuanDu(tb As TextBox) 'tb为文本框型的控件对象参数
tb.Text = "文本框的宽度是"& tb.Width
End Sub
调用过程KuanDu会改变文本框对象tb的文本。
（3）编写按钮的单击事件过程，用来调用具有对象参数的过程。
Private Sub Command1_Click()
Call BiaoTi(Form1)
End Sub
Private Sub Command2_Click()
Call KuanDu(Text1)
End Sub
【例6-11】
Function fac(n As Integer) As Long
If n = 1 Then
Fac = 1
Else
Fac = n * fac(n - 1)
End If
End Function
【例6-12】
Private Sub Command1_Click()
Dim a As Integer,b As Integer '过程级变量
A = 100:b = 8
Print
Print"调用s1前，事件过程中的变量:";"a=";a;"b=";b
Call s1 '调用通用过程sub1
Print
Print" 调用s1后，事件过程中的变量:";"a=";a;"b=";b
End Sub
Sub s1() '通用过程
Dim a As Integer,b As Integer '过程级变量
A = 55:b = 66
Print
Print"通用过程s1中的变量:";"a=";a;"b=";b
End Sub
【例6-13】
Dim a As Integer,b As Integer '声明模块级变量
Private Sub Command1_Click()
A = 100:b = 8 '对模块级变量赋值
Print
Print"调用s1前，模块级变量:";"a=";a;"b=";b
Call s1 '调用通用过程sub1
Print
Print"调用s1后，模块级变量:";"a=";a;"b=";b
End Sub
Sub s1() '通用过程
A = 55:b = 66 '对模块级变量赋值
Print
Print"通用过程s1对模块级变量赋值:";"a=";a;"b=";b
End Sub
【例6-14】
（4）在窗体Form1的代码窗口的顶部，声明模块级变量a和b，分别用来储存程序运行后单击左右两个命令按钮的次数。代码如下：
Private a As Integer
Private b As Integer
（5）编写左边的命令按钮的Command1_Clic事件过程。代码如下：
Private Sub Command1_Click()
Dim s As String
I = I + 1
A = a + 1
S = "单击按钮"& i &"次,左按钮"& a &"次"
MsgBox s,vbOKOnly,"提示"
End Sub
（6）编写右边的命令按钮的Command2_Clic事件过程。代码如下：
Private Sub Command2_Click()
Dim s As String
I = I + 1
B = b + 1
S = "单击按钮"& i &"次,右按钮"& b &"次"
MsgBox s,vbOKOnly,"提示"
End Sub
【例6-15】
Sub change()
Dim d As Integer '声明动态变量d
Static s As Integer '声明静态变量s
D = d + 1
S = s + 1
Print "动态变量d = ";d,"静态变量s = ";s
End Sub
Private Sub Command1_Click()
Dim i As Integer
For i = 1 To 3
change '或 Call change
Next i
End Sub
实训
（3）在Form1的窗体模块的代码窗口的最顶部（通用声明段）声明模块级变量title，用来存储字符串。代码如下：
Private title As String '表明是使用通用过程还是函数
（4）定义Sub通用过程MySub，来进行乘法运算。其中的形参x、y按值传递，形参z按地址传递。代码如下：
Private Sub MySub(ByVal x As Integer,ByVal y As Integer,z As Integer)
Z = x * y
End Sub
定义函数过程MyFun，来进行加法运算。其中的形参m和n是按值传递的。代码如下：
Private Function MyFun(ByVal m As Integer,ByVal n As Integer) As Integer
MyFun=m+n
End Function
（5）添加窗体的事件过程Form_Load，来做些初始化的工作，将文本框置空。代码如下：
Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
End Sub
分别添加两个单选按钮的Click事件过程，来设置框架Frame1和标签Label的Caption属性。代码如下：
Private Sub Option1_Click()
Frame1.Caption = "乘法积运算"
Label1.Caption = "×"
End Sub
Private Sub Option2_Click()
Frame1.Caption = "加法运算"
Label1.Caption = "+"
End Sub
添加命令按钮的事件过程Command1_Click。其中，关键字static声明的静态变量i和j用来储存运算的次数，关键字Dim声明的过程级局部变量a、b、c用来储存三个文本框里的数值。代码如下：
Private Sub Command1_Click()
Static i As Integer,j As Integer
Dim a As Integer,b As Integer,c As Integer
A = Val(Text1.Text)
B = Val(Text2.Text)
If Option1.Value=True Then
Title = "用过程运算"
Call MySub(a,b,c)
i=i+1
Form1.Caption = "第"& i &"次"& title
Else
Title = "用函数运算"
c=MyFun(a,b)
j = j+1
Form1.Caption = "第"& j &"次"& title
End If
Text3.Text = c
End Sub
第7章课前体验
Private Sub Frame1_MouseDown(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
Form1.Caption = "测试鼠标事件"
Select Case Button
Case 1 '左键，或用常量Visual BasicLeftButton
FrameLeft.BackColor = Visual BasicRed
FrameRight.BackColor = Visual BasicWhite
Frame1.ToolTipText = "朋友，您刚才在这按了鼠标左键！"
Case 2 '右键,或用常量Visual BasicRightButton
FrameRight.BackColor = Visual BasicRed
FrameLeft.BackColor = Visual BasicWhite
Frame1.ToolTipText = "朋友，您刚才在这按了鼠标右键！"
End Select
End Sub
【例7-1】
Private Sub Form_MouseDown(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
Print"您触发了MouseDown事件！"
End Sub
Private Sub Form_MouseUp(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
Print"您又触发了MouseUp事件！"
End Sub
【例7-2】
Private Sub Form_MouseMove(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
If Shift=1 And Button=1Then
Cls
Print"鼠标指针当前横坐标X=";X
Else
Cls
Print"鼠标指针当前纵坐标Y=";Y
End If
End Sub
【例7-3】
1）首先，在窗体模块的顶部声明一个逻辑变量paint，如下：
Private paint As Boolean
（2）定义窗体上的按下鼠标按键的事件过程，使得变量paint的值在按鼠标左键时为true。再定义释放鼠标按键的事件过程，使得变量paint的值为false。代码如下：
Private Sub Form_MouseDown(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
If Button=1 Then
paint=True
End If
End Sub
Private Sub Form_MouseUp(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
paint = False
End Sub
（3）定义窗体上的鼠标移动事件过程。
Private Sub Form_MouseMove(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
If paint Then ’paint为true时，程序画出轨迹点
PSet(X,Y)
End If
End Sub
【例7-4】
（2）定义窗体的Form_load事件过程，使列表框中添加几个选项。代码如下：
Private Sub Form_Load()
List1.AddItem"0-Default"
List1.AddItem"1-Arrow"
List1.AddItem"2-Cross"
List1.AddItem"3-I-Beam"
End Sub
（3）定义列表框的单击事件过程。
Private Sub List1_Click()
Form1.MousePointer=List1.ListIndex
End Sub
【例7-5】
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii >= 97 And KeyAscii <= 122 Then
Print"小写字母：";Chr(KeyAscii);"，ASCII码：";KeyAscii
End If
If KeyAscii >= 65 And KeyAscii<=90 Then
Print"大写字母：";Chr(KeyAscii);"，ASCII码：";KeyAscii
End If
End Sub
【例7-6】
Private Sub Form_KeyDown(KeyCode As Integer,Shift As Integer)
Dim color As String
color=Chr(KeyCode)
Select Case color
Case"W"
Label1.BackColor = Visual BasicWhite
Case"R"
Label1.BackColor=Visual BasicRed
Case"G"
Label1.BackColor=Visual BasicGreen
Case "B"
Label1.BackColor=Visual BasicBlue
End Select
End Sub
【例7-7】
Private Sub Form_KeyDown(KeyCode As Integer,Shift As Integer)
Select Case Shift
Case1
Label1.Caption="你按了【SHIFT】键！"
Case2
Label1.Caption="你按了【CTRL】键！"
Case4
Label1.Caption="你按了 【ALT】键！"
Case3
Label1.Caption="你同时按了SHIFT和【CTRL】键！"
Case5
Label1.Caption="你同时按了SHIFT和【ALT】键！"
Case6
Label1.Caption="你同时按了CTRL和【ALT】键！"
Case7
Label1.Caption="你同时按了SHIFT、CTRL和【ALT】键！"
End Select
End Sub
【例7-9】
Private Sub Form_Click()
If Command1.DragMode = 0 Then
Command1.DragMode = 1
Else
Command1.DragMode = 0
End If
End Sub
【例7-11】
Private Sub Picture2_DragDrop(Source As Control,X As Single,Y As Single)
If TypeOf Source Is PictureBox Then
Picture2.Picture=Source.Picture
End If
End Sub
【例7-12】
Private Sub Picture1_DragOver(Source As Control,X As Single,_
Y As Single,State As Integer)
Select Case State
Case0
Source.DragIcon=LoadPicture(App.Path & "\4.ico")
Case1
Source.DragIcon=LoadPicture()
End Select
End Sub
【例7-13】
（2）编写文本框的MouseDown事件过程，代码如下：
Private Sub Text1_MouseDown(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
Text1.Drag1
End Sub
过程中使用Drag方法启动文本框的拖放操作；
（3）编写文本框的事件过程，代码如下：
Private Sub Text1_MouseUp(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
Text1.Drag 2
End Sub
过程中使用Drag方法结束文本框的拖放操作
（4）编写窗体的DragDrop事件过程，代码如下：
Private Sub Form_DragDrop(Source As Control,X As Single,Y As Single)
Source.Move(X-Source.Width/2),(Y-Source.Height/2)
End Sub
实训
（3）在Form1的窗体模块的代码窗口的最顶部（通用声明段）声明模块级变量paint，用来存储逻辑型数据。代码如下：
Private paint As Boolean
（4）定义各鼠标事件过程。
①事件过程Form_MouseDown的代码如下：
Private Sub Form_MouseDown(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
paint = True '允许绘图
DrawWidth = 1 '设置绘图线宽
PSet (X,Y) '使用画点方法
End Sub
事件过程Form_MouseMove的代码如下：
Private Sub Form_MouseMove(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
If paint Then
If Button = 1 Then '按住的是左键
MousePointer = 1 '指针设置成箭头形状，表示画笔
DrawWidth = 4
Line-(X,Y),Visual BasicBlue '使用画点方法
End If
If Button = 2 Then '按住的是右键
MousePointer = 11 '指针设置成箭头形状，表示橡皮擦
DrawWidth = 16
Line -(X,Y),Visual BasicWhite
End If
End If
End Sub
事件过程Form_MouseUp的代码如下：
Private Sub Form_MouseUp(Button As Integer,Shift As Integer,_
X As Single,Y As Single)
paint = False '表示不允许鼠标绘图
MousePointer = 1
End Sub
事件过程Form_DblClick的代码如下：
Private Sub Form_DblClick()
Cls
End Sub
（4）定义各键盘事件过程Form_KeyPress，代码如下：
Private Sub Form_KeyPress(KeyAscii As Integer)
Print Chr(KeyAscii);
End Sub
第8章课前体验
（3）编写程序代码
①为窗体Form1编写代码命令按钮的单击事件过程如下：
Private Sub Command1_Click()
Form1.Hide
Form2.Show
Form2.Caption = Form1.Text1 + "的打字练习！" ’Form1.Text1为用户名
End Sub
②为窗体Form2编写代码
“重新登录”按钮Command1的单击事件过程如下：
Private Sub Command1_Click()
Form2.Hide
Form1.Show
End Sub
“清屏”按钮Command2的单击事件过程如下：
Private Sub Command2_Click()
Text1.Text = ""
End Sub
,关闭”按钮Command3的单击事件过程如下：
Private Sub Command3_Click()
End
End Sub
【例8-2】
X As Single,Y As Single)
If Button=2 Then
PopupMenu play
End If
End Sub
【例8-3】
（1）“文件(&F)”主菜单中各菜单项的事件过程
Private Sub mnuClear_Click()
Cls
End Sub
Private Sub mnuExit_Click()
End
End Sub
该过程的功能是退出应用程序。
（2）“格式(&S)”主菜单中各菜单项的事件过程
Private Sub mnuBold_Click()
If mnuBold.Checked=True Then
Text1.FontBold=False
mnuBold.Checked=False
Else
Text1.FontBold=True
mnuBold.Checked=True
End If
End Sub
该过程在用户选择“格式”主菜单下的“粗体”菜单项时执行，实现将文本框中的文字变为粗体显示，如果文字已经是粗体显示，则将文字变为正常显示。
Private Sub mnuUnder_Click()
If mnuUnder.Checked = True Then
Text1.FontUnderline = False
mnuUnder.Checked = False
Else
Text1.FontUnderline = True
mnuUnder.Checked = True
End If
End Sub
该过程在用户选择“格式”主菜单下的“下画线”菜单项时执行，实现将文本框中的文字添加下画线，如果文字已经具有下画线，则将文字的下画线取消。
Private Sub mnuItalic_Click()
If mnuItalic.Checked = True Then
Text1.FontItalic = False
mnuItalic.Checked = False
Else
Text1.FontItalic = True
mnuItalic.Checked = True
End If
End Sub
该过程在用户选择“格式”主菜单下的“倾体”菜单项时执行，实现将文本框中的文字变为斜体显示，如果文字已经是斜体显示，则将文字变为正常显示。
（3）“前景颜色(&Q)”子菜单中各菜单项的事件过程
Private Sub mnuRed_Click()
Text1.ForeColor = vbRed
End Sub
Private Sub mnuBlue_Click()
Text1.ForeColor = vbBlue
End Sub
（4）“帮助(&H)”主菜单项中各菜单项的事件过程
Private Sub mnuAbout_Click()
MsgBox"菜单设计实例",vbYes,"关于"
End Sub
Private Sub mnuSoft_Click()
MsgBox"如有任何问题，请与作者联系！",vbYes,"使用帮助"
End Sub
【例8-4】
（1）编写弹出式菜单“娱乐”中各菜单项的事件过程
·①“画图”菜单项的事件过程
Private Sub menuPaint_Click()
Shell("c:\program files\accessories\mspaint.exe"),vbNormalFocus
End Sub
·②“纸牌”菜单项的事件过程
Private Sub menuPoker_Click()
Shell ("c:\windows\sol.exe"),vbNormalFocus
End Sub
（2）编写下拉式菜单“办公”中各菜单项的事件过程
①单击“电子文档“菜单项的事件过程
Private Sub menuWord_Click()
Shell("c:\program files\microsoft office\office\winword.exe"),vbNormalFocus
End Sub
·②单击“电子表格”菜单项的事件过程
Private Sub menuExcel_Click()
Shell("c:\program files\microsoft office\office\excel.exe"),vbNormalFocus
End Sub
【例8-6】
（2）编写命令按钮Command1(浏览)的单击事件过程：
Private Sub Command1_Click()
CommonDialog1.Filter = "图片文件|*.bmp;*.jpg;*.gif"
CommonDialog1.ShowOpen '或CommonDialog1.Action = 1
Picture1.Picture = LoadPicture(CommonDialog1.FileName)
End Sub
（3）编写命令按钮Command2(保存)的单击事件过程：
Private Sub Command2_Click()
CommonDialog1.InitDir = "d:\"
CommonDialog1.FileName = "tu.bmp"
CommonDialog1.Filter = "BMP文件|*.bmp"
CommonDialog1.ShowSave '或CommonDialog1.Action = 2
SavePicture Picture1.Picture,CommonDialog1.FileName
End Sub
【例8-7】
（2）编写命令按钮Command1(设置颜色)的单击事件过程：
Private Sub Command1_Click()
CommonDialog1.ShowColor '或CommonDialog1.Action=3
Text1.ForeColor=CommonDialog1.Color
End Sub
（3）编写命令按钮Command2(设置字体)的单击事件过程：
Private Sub Command2_Click()
CommonDialog1.Action = 4 '或CommonDialog1.ShowFont
Text1.FontName = CommonDialog1.FontName
Text1.FontSize = CommonDialog1.FontSize
Text1.FontBold = CommonDialog1.FontBold
Text1.FontItalic = CommonDialog1.FontItalic
Text1.FontUnderline = CommonDialog1.FontUnderline
End Sub
【例8-8】
（2）编写程序代码如下：
Private Sub Form_Load()
StatusBar1.Panels(1).Text=Date
End Sub
该事件过程使得程序启动后，状态栏窗格1上显示当前的日期。
Private Sub Text1_KeyPress(KeyAscii As Integer)
StatusBar1.Panels(2).Text = "文本框1上输入"
End Sub
当在文本框Text1上输入时，调用该事件过程，使得状态栏窗格2上显示“文本框1上输入”。
Private Sub Text2_KeyPress(KeyAscii As Integer)
StatusBar1.Panels(2).Text = "文本框2上输入"
End Sub
【例8-10】
（3）编写3个复选框的事件过程：
Private Sub Check1_Click()
Text1.FontBold = Not Text1.FontBold
End Sub
Private Sub Check2_Click()
Text1.FontItalic = Not Text1.FontItalic
End Sub
Private Sub Check3_Click()
Text1.FontUnderline = Not Text1.FontUnderline
End Sub
（4）编写命令按钮的事件过程：
Private Sub Command1_Click()
CommonDialog1.ShowColor
Text1.ForeColor = CommonDialog1.Color
End Sub
【例8-11】
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
Text1.FontBold = Button.Value
Case 2
Text1.FontItalic = Button.Value
Case 3
Text1.FontUnderline = Button.Value
Case 5
CommonDialog1.ShowColor
Text1.ForeColor = CommonDialog1.Color
End Select
End Sub
【例8-12】
（3）在MDIForm1的代码窗口中，编写代码。
在顶部通用声明段，声明变量n来储存子窗体编号，代码如下：
Private n As Integer
编写“文件”菜单中各菜单项的事件过程，代码如下：
Private Sub menuNew_Click()
N ﹦ n + 1
Dim Fm As New Form1 '定义窗体
Load Fm '装载窗体
Fm.Caption = "新文档"&n
End Sub
该过程，定义一个子窗体对象，然后加载显示在父窗体中，并设置了窗体标题。
Private Sub menuExit_Click()
End
End Sub
该过程关闭应用程序。
编写“窗口排列”菜单中各菜单项的事件过程，代码如下：
Private Sub menuCascade_Click()
MDIForm1.Arrange0
End Sub
Private Sub menuH_Click()
MDIForm1.Arrange1
End Sub
Private Sub menuV_Click()
MDIForm1.Arrange2
End Sub
实训
（3）编写窗体模块Form1里的代码
①在代码窗口顶部声明一个公用的模块级变量user，用来保存用户名。代码如下：
Public user As String'用户名变量
②编写命令按钮的单击事件过程：
Private Sub Command1_Click()
If Option1.Value = True Then
User = Text1.Text & "先生"
Else
User = Text1.Text & "女士"
End If
Form1.Hide
Form2.Show
End Sub
调用该过程，变量user根据用户对单选按钮的选择来保存“某某先生”或“某某女士”，然后隐藏登陆界面（窗体Form1），显示主界面（窗体Form2）。
Private Sub Command2_Click()
End
End Sub
该过程关闭应用程序。
（4）编写窗体模块Form2里的代码
①在代码窗口顶部声明一个模块级变量clip，当成剪贴板来保存字符串。代码如下：
Private clip As String
②窗体加载的事件过程如下：
Private Sub Form_Load()
StatusBar1.Panels(1).Text = Form1.user
End Sub
该过程使状态栏的第一个窗格里显示用户名。
③高级文本框的change事件过程如下：
Private Sub RichTextBox1_Change()
StatusBar1.Panels(2).Text = "正在输入..."
End Sub
该过程使状态栏的第二个窗格里显示输入状态。
④计时器的Timer事件过程如下：
Private Sub Timer1_Timer()
StatusBar1.Panels(3).Text = "时钟："& Time
End Sub
该过程使状态栏的第3个窗格里显示当前时间。
⑤工具栏的按钮单击事件过程如下：
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
RichTextBox1.Text = ""
Case 2
CommonDialog1.ShowPrinter
Case 3
RichTextBox1.SelBold = Not RichTextBox1.SelBold
Case 4
RichTextBox1.SelItalic = Not RichTextBox1.SelItalic
Case 5
RichTextBox1.SelUnderline = Not RichTextBox1.SelUnderline
Case 6
CommonDialog1.ShowColor
RichTextBox1.SelColor = CommonDialog1.Color
Case 8
MsgBox "可用菜单或工具栏来操作",vbOKOnly,"关于文本编辑器"
End Select
End Sub
⑥为高级文本框RichTextBox1编写鼠标MouseDown事件过程，如下：
Private Sub RichTextBox1_MouseDown(Button As Integer,Shift As Integer,_
x As Single,y As Single)
If Button = 2 Then
If RichTextBox1.SelText<>""Then
menuCut.Enabled = True
menuCopy.Enabled = True
End If
PopupMenu Edit
End If
End Sub
⑦为“编辑”菜单中的各菜单项编写单击事件过程
Private Sub menuCut_Click()
Clip = RichTextBox1.SelText
RichTextBox1.SelText = "" '将选定的字符清除
menuCut.Enabled = False
menuCopy.Enabled = False '将"剪切"与"复制"菜单项设为无效
menuPaste.Enabled = True
End Sub
Private Sub menuCopy_Click()
clip = RichTextBox1.SelText
menuCut.Enabled = False
menuCopy.Enabled = False
menuPaste.Enabled = True
End Sub
Private Sub menuPaste_Click()
RichTextBox1.SelText = clip '将变量clip中的内容粘贴到光标所在处
End Sub
上述3个菜单项的事件过程分别实现了RichTextBox1上的复制、剪切和粘贴的功能。
Private Sub menuSelAll_Click()
RichTextBox1.SelStart = 0
RichTextBox1.SelLength = Len(RichTextBox1.Text)
End Sub
第9章课前体验
（3）双击窗体，在窗体的Load事件中编写如下程序：
Dim Snow(1000,2),Amounty As Integer
Private Sub Form_Load()
Form1.Show
DoEvents
Randomize
Amounty = 325
For J = 1 To Amounty
Snow(J,0) = Int(Rnd ＊ Form1.Width)
Snow(J,1) = Int(Rnd ＊ Form1.Height)
Snow(J,2) = 10 ＋ (Rnd ＊ 20)
Next J
Do While Not (DoEvents = 0)
For LS = 1 To 10
For I = 1 To Amounty
OldX = Snow(I,0),OldY = Snow(I,1)
Snow(I,1) = Snow(I,1) ＋ Snow(I,2)
If Snow(I,1) > Form1.Height Then
Snow(I,1) = 0,Snow(I,2) = 5 ＋ (Rnd ＊ 30)
Snow(I,0) = Int(Rnd ＊ Form1.Width)
OldX = 0,OldY = 0
End If
Coloury = 8 ＊ (Snow(I,2) － 10),Coloury = 60 ＋ Coloury
PSet (OldX,OldY),QBColor(0)
PSet (Snow(I,0),Snow(I,1)),RGB(Coloury,Coloury,Coloury)
Next I
Next LS
Loop
End
End Sub
（4）编写窗体的鼠标按下代码，在窗体的MouseDown事件中编程：
Private Sub Form_MouseDown(Button As Integer,Shift As Integer,X As Single,Y As Single)
unload me
End Sub
【例9-1】
Private Sub Command1_Click()
Dim I As Integer
For I = 0 To 5
Shape1(I).Shape = I ‘将控件数组中第I个控件的形状属性改为I
Next
End Sub
Private Sub Command2_Click()
Dim I As Integer
For I = 0 To 5
Shape1(I).BackStyle = 1 ‘将控件的背景类型更改为“覆盖”
Shape1(I).BackColor = QBColor(I) ‘更改控件的背景颜色
Next
End Sub
Private Sub Command3_Click()
Dim I As Integer
For I = 0 To 5
Shape1(I).FillColor = RGB(255,255,255) ‘将控件的填充颜色改为白色
Shape1(I).FillStyle = I + 2 ‘更改控件的填充方式。因其值为0时为覆盖方式，其值为1时为透明方式，看不出填充效果，故将值设为从2开始。
Next
End Sub
【例9-2】
Private Sub Command1_Click()
Line(-2,0)-(10,0) ‘画出X轴
Line(0,3)-(0,-3) ‘画出Y轴
For i = 0 To 6.28 Step 0.001
j = Sin(i)
PSet(i,j) ‘ 画出正弦函数图像
Next i
End Sub
Private Sub Form_Load()
Form1.Scale(-2,3)-(10,-3) ‘定义坐标系
End Sub
【例9-3】
Private Sub Form_Click()
Line(500,700)-(2500,700),vbRed
Line(1500,100)-(700,2000),vbGreen
Line(1500,100)-(2300,2000),vbGreen
Line(2500,700)-(700,2000),vbBlue
Line(500,700)-(2300,2000),vbBlue
End Sub
【例9-4】
Private Sub Form_Click()
Cls
r = Form2.ScaleHeight / 2 ' 圆半径为窗体高度的1/2
x0 = Form2.ScaleWidth / 2 ' 圆的中心坐标（窗体中间）
y0 = Form2.ScaleHeight / 2
st = 3.1415926 / 10 ' 将圆等分为 20 份
For i = 0 To 6.283185 Step st ' 用直线将圆周上的这些点两两相连
For j = 0 To i Step st
X1 = x0 + r * Cos(i)
Y1 = y0 - r * Sin(i)
X2 = x0 + r * Cos(j)
Y2 = y0 - r * Sin(j)
Line (X1,Y1)-(X2,Y2)
Next j,i
End Sub
【例9-5】
Private Sub Form_Click()
Cls
r = Form1.ScaleHeight/4 ‘ 圆半径为窗体高度的1/4
x0 = Form1.ScaleWidth/2 ‘ 圆的中心坐标（窗体中间）
y0 = Form1.ScaleHeight/2
st = 3.1415926/25 ‘ 将圆等分为 50 份
For i = 0 To 6.283185 Step st ‘ 以每一个等分点为圆心画圆
x = x0 + r * Cos(i)
y = y0 - r * Sin(i)
Circle(x,y),r * 0.8
Next i
End Sub
【例9-6】
Private Sub Form_Click()
Dim numm As Integer
Picture1.AutoSize = True ‘图片框大小与图片大小一致
roww = Int(Form1.Width / Picture1.Width) + 1 ‘计算每行可放置多少个图片
coll = Int(Form1.Height / Picture1.Height) + 1 ‘计算每列可放置多少个图片
For i = 0 To roww
For j = 0 To coll
Form1.PaintPicture Picture1.Picture,i * Picture1.Width,j * Picture1.Height,Picture1.Width,Picture1.Height
‘在窗体的行、列上复制图片
Next j
Next i
Picture1.Visible = False
End Sub
Private Sub Form_Load()
Picture1.Picture = LoadPicture("d:\1.bmp") ‘在图片框中装入图片
Form1.Caption = "图像平铺"
End Sub
【例9-7】
Private Sub Form_Click()
Picture1.Cls
End Sub
Private Sub Form_Load()
Picture1.ScaleHeight = 100 '设置比例为100.
Picture1.ScaleWidth = 100
Picture1.AutoRedraw = True '打开AutoRedraw
Picture1.ForeColor = 0 '设置ForeColor
Picture1.FillColor = QBColor(9) '设置FillColor
Picture1.FillStyle = 0 '设置FillStyle
Picture1.Circle (50,50),30 '画一个圆
Picture1.AutoRedraw = False '关闭AutoRedraw
End Sub
Private Sub Picture1_Click()
Dim I
Picture1.ForeColor =RGB(Rnd * 255,0,0) '选择随机颜色.
For I = 5 To 95 Step 10 '画线.
Picture1.Line (I,0)-(I,100)
Next I
End Sub
【例9-8】
Private Sub Form_Paint()
Dim HalfX,HalfY '声明变量.
HalfX = ScaleLeft + ScaleWidth/2 '圆半径设置到宽度的一半。
HalfY = ScaleTop + ScaleHeight/2 '圆半径设置到高度的一半。画一个圆。
If HalfX > HalfY Then
Circle (HalfX,HalfY),HalfY
Else
Circle (HalfX,HalfY),HalfX
End If
End Sub
Private Sub Form_Resize()
Refresh
End Sub
实训
Private Sub Form_Click()
Form1.Scale(-2 * 3.14159,1)-(2 * 3.14159,-1)
Form1.Line (-2 * 3.14159,0)-(2 * 3.14159,0)
Form1.Line(0,1)-(0,-1)
Form1.CurrentX = 0.2:Form1.CurrentY = -0.1:Print"0"
Form1.CurrentX = -3.2:Form1.CurrentY = -0.1:Print"-pi"
Form1.CurrentX = 3.3:Form1.CurrentY = -0.1:Print"pi"
Form1.CurrentX = -6.2:Form1.CurrentY = -0.1,Print "-2pi"
Form1.CurrentX = 5.7:Form1.CurrentY = -0.1:Print "2pi"
Form1.CurrentX = 0.2:Form1.CurrentY = 0.5:Print "0.5"
Form1.CurrentX = 0.2:Form1.CurrentY = -0.5:Print"-0.5"
For I = -6.282 To 6.282 Step 0.02
Form1.PSet (I,Cos(I))
Next I
End Sub
第10章课前体验
Private Sub Combo1_Click()
File1.Pattern = Combo1.Text ‘对文件类型进行过滤
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path ‘目录列表框与文件列表框同步
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive ‘目录列表框与驱动器列表框同步
End Sub
Private Sub Form_Load()
File1.Pattern = "*.exe" ‘程序运行时，默认显示EXE文件
End Sub
【例10-1】
Private Sub Form_Load()
Open "D:\Myfile2.txt" For Output As #1 '打开输出文件
Print #1,"Print #语句测试" '向文件中输出一行数据
Print #1,'向文件中输出一个空行
Print #1,"第一分区","第二分区" '分区格式输出数据
Print #1,"你好！"; 2 * 3,2 + 3 '按紧凑、分区两种格式输出数据
Print #1,Spc(2); "前面输出2个空格" 'Spc函数向文件中写入两个空格
Print #1,Tab(5); "从第5列开始输出" 'Tab函数指定从第5列开始输出
Print #1,"行1" '换行测试
Print #1,"行2"
Close #1 '关闭文件
End Sub
【例10-2】
（1）把文本文件的内容一行一行地读入文本框
Text1.Text =,” ‘将文本框置空
Open“D:\Myfile.txt” For Input As #1
‘以Input方式打开文件“D:\Myfile.txt”文件，文件号为1。
Do While Not EOF(1) ‘判断文件是否结束
Line Input #1,InputData ‘一次从文件中读入一行，赋给变量InputData
Text1.Text = Text1.Text+InputData + vbCrlf
‘将InputData变量的值与文本框值连接
Loop
Close #1
（2）把文本文件的内容一个字符一个字符地读入文框
Dim InputData As String
Text1.Text =,”
Open,D:\Myfile.txt” For Input As #1
Do While Not EOF(1) ‘判断文件是否结束
InputData=Input(1,#1) ‘每次读一个字符
Text1.Text=Text1.Text+InputData ‘与文本框内容相连接
Loop
Close #1
（3）把文本文件的内容一次性读入文本框（仅限于包含西文字符的文本方件）
Text1.Text = ""
Open "D:\Myfile.txt" For Input As #1
Text1.Text = Input(LOF(1),#1)
‘将整个文件的内容全部读出，在文本框中显示出来。
Close #1
【例10-3】
Private Type Student '用户自定义数据类型
Name As String * 8
Age As String * 3
End Type
Private Sub Command1_Click() '"添加记录"命令按钮
Dim s As Student
Dim I As Integer
Open "D:\XueSheng.dat"For Random As #1 Len = Len(s) '打开文件
I = LOF(1)/Len(s) '计算记录号
s.Name = Text1.Text
s.Age = Text2.Text
Put #1,I + 1,s '写入数据，记录号为I+1
Text1.Text =""
Text2.Text ="" '清空Text1和Text2
Text1.SetFocus '置Text1为焦点。
Close '关闭文件
End Sub
Private Sub Command2_Click() '退出命令按钮
End
End Sub
【例10-4】
Private Sub Command1_Click()
Dim fso As New FileSystemObject,drv As Drive,s As String ‘定义一个FSO对象
Set drv = fso.GetDrive(fso.GetDriveName("c:")) ‘取出C盘当前路径
s = "Drive " & UCase("c:") & " - "
s = s & drv.VolumeName & vbCrLf ‘取出C盘的卷标
s = s & "Total Space," & FormatNumber(drv.TotalSize / 1024,0)
‘取出C盘总共的磁盘空间，并换算成KB
s = s & " Kb" & vbCrLf
s = s & "Free Space," & FormatNumber(drv.FreeSpace /1024,0)
‘取出C盘剩余的磁盘空间，并换算成KB
s = s & " Kb" & vbCrLf
MsgBox sEnd
Sub
【例10-5】
Private Sub Command1_Click()
Set fso = CreateObject("Scripting.FileSystemObject")
'Set f1 = fso.CreateTextFile("c:\test1.txt",True) '使用CreateTextFile创建文件
'Set f1 = fso.OpenTextFile("c:\test2.txt",ForWriting,True) '使用OpenTextFile创建文件
fso.CreateTextFile ("c:\test3.txt")
Set ft = fso.GetFile("c:\test3.txt")
Set f1 = ft.OpenAsTextStream(ForWriting,True) '以上三条语句使用OpenAsTextStream创建文件
f1.WriteLine ("This is a test!") '写入一行带有换行符的文本
f1.WriteBlankLines (3) '向文件中写入三个换行符。
f1.Write (3+2) '写入表达式3+2的值5
f1.Close
End Sub
【例10-6】
Private Sub Command2_Click()
Set fso = CreateObject("Scripting.FileSystemObject") ‘定义FSO对象
Set f1 = fso.OpenTextFile("c:\test1.txt",ForReading) ‘打开文件用于读
s1 = f1.ReadAll ‘将文件中内容一次性全部读出
Text1.Text = s1
f1.Close
End Sub
也可使用ReadLine方法，程序如下：
Private Sub Command2_Click()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f1 = fso.OpenTextFile("c:\test1.txt",ForReading)
s1 = ""
Do While Not f1.AtEndOfStream
s1 = s1 & f1.ReadLine + vbCrLf
Loop
Text1.Text = s1
f1.Close
End Sub
实训
Dim sn(25) As Integer
Private Sub Command1_Click()
Open "d:\tj1.txt" For Input As #1
Do While Not EOF(1)
s1 = Input$(1,#1)
For i = 0 To 25
If UCase$(s1) = Chr$(65 + i) Then
sn(i) = sn(i) + 1
End If
Next i
Loop
Close #1
For i = 0 To 25
Text1.Text = Text1.Text + "字母" + Chr$(65 + i) + "的个数为：" + Str(sn(i)) + vbCrLf
Next i
End Sub
Private Sub Command2_Click()
Open "d:\tj1.txt" For Append As #1
For i = 0 To 25
Print #1,vbCrLf + "字母" + Chr$(65 + i) + "的个数为：" + Str(sn(i))
Next i
Close #1
End Sub
第11章课前体验在窗体的Form_Load()事件、5个命令按钮的Click()事件中分别输入以下程序：
（1）Form_Load() 事件
Private Sub Form_Load()
cmdUpdata.Enabled = False '使更新按钮不可用
End Sub
（2）“更新”按钮
Private Sub cmdAdd_Click()
Data1.Recordset.AddNew '添加新记录
cmdUpdata.Enabled = True '激活更新按钮
End Sub
（3）“删除”按钮
Private Sub cmdDel_Click()
Data1.Recordset.Delete '删除当前记录
End Sub
（4）“修改”按钮
Private Sub cmdEdit_Click()
Data1.Recordset.Edit '开始修改记录
cmdUpdata.Enabled = True '激活更新按钮
End Sub
（5）“退出”按钮
Private Sub cmdExit_Click()
End '退出程序
End Sub
（6）“添加”按钮
Private Sub cmdUpdata_Click()
Data1.Recordset.Update '更新记录
cmdUpdata.Enabled = False '使更新按钮不可用
End Sub
实训
（3）编写程序：对各命令按钮的Click()事件编程如下
①“增加职工”按钮的Click()事件
Private Sub Command1_Click()
If Command1.Caption = "增加职工" Then
Data1.Recordset.AddNew
Command1.Caption = "确定"
Command2.Caption = "取消"
Command3.Enabled = False
ElseIf Command1.Caption = "确定" Then
Text9.Text = Val(Text2) + Val(Text5) + Val(Text8) - Val(Text3) - Val(Text6)
Data1.Recordset.Update
Command1.Caption = "增加职工"
Command2.Caption = "删除职工"
Command3.Enabled = True
End If
End Sub
②“删除职工”按钮的Click()事件：
Private Sub Command2_Click()
If Command2.Caption = "删除职工" Then
Data1.Recordset.Delete
If Not Data1.Recordset.EOF Then
Data1.Recordset.MoveNext
ElseIf Not Data1.Recordset.BOF Then
Data1.Recordset.MovePrevious
Else
MsgBox ("这是最后一条记录")
End If
ElseIf Command2.Caption = "取消" Then
Data1.Recordset.CancelUpdate
End If
End Sub
③“修改数据”按钮的Click()事件
Private Sub Command3_Click()
Data1.Recordset.Edit
Command1.Caption = "确定"
Command2.Caption = "取消"
Command3.Enabled = False
End Sub
④“退出”按钮的Click()事件
Private Sub Command4_Click()
End
End Sub
第12章
12.4.2
Dim trytimes As Integer '尝试登陆次数
‘命令按钮“确定”的Click事件
Private Sub cmdCancel_Click()
If MsgBox("你选择了退出登陆，是否退出?",_
vbYesNo + vbInformation,"用户登陆") = vbYes Then
End
Else
Exit Sub
End If
End Sub
‘命令按钮“确定”的Click事件
Private Sub cmdOK_Click()
Dim sName As String,sPas As String
Dim mrs As ADODB.Recordset,strSQL As String
sName = Trim(txtUserName.Text),sPas = Trim(txtPassword.Text)
'数据有效性检查
If sName = "" Then
MsgBox "请输入用户名!",vbCritical,"用户登陆验证"
txtUserName.SetFocus
‘若用户名为空，则提示输入用户名，并将定位在用户名文本框
Exit Sub
End If
If sPas = "" Then
MsgBox "请输入密码!",vbCritical,"用户登陆验证"
txtPassword.SetFocus
‘若用户密码为空，则提示输入密码，并将定位在密码文本框
Exit Sub
End If
'检查用户名是否正确
strSQL = "select * from 用户表 where 用户名='" & sName & "'"
Set mrs = conn.Execute(strSQL)
If mrs.EOF = True Then
MsgBox "用户名不存在！",vbCritical,"用户登陆验证"
try_times = try_times + 1
If try_times >= 3 Then
MsgBox "您已经三次尝试进入本系统，均不成功，系统将关闭！",_
vbCritical,"用户登陆验证"
End
Else
txtUserName.SetFocus
txtUserName.SelStart = 0
txtUserName.SelLength = Len(txtUserName.Text)
Exit Sub
End If
End If
strSQL = "select * from 用户表 where 用户名='" & sName & "'" & _
"and 密码='" & sPas & "'"
Set mrs = conn.Execute(strSQL)
If mrs.EOF = True Then
MsgBox " 密码错误！",vbCritical,"用户登陆验证"
try_times = try_times + 1
If try_times >= 3 Then
MsgBox "您已经三次尝试进入本系统，均不成功，系统将关闭！",_
vbCritical,"用户登陆验证"
End
Else
txtPassword.SetFocus
txtPassword.SelStart = 0
txtPassword.SelLength = Len(txtPassword.Text)
Exit Sub
End If
End If
MsgBox "登陆成功！",vbInformation,"用户登陆验证"
'保存当前登陆的权限
bolAuthority = mrs.Fields("权限")
'加载MDI主窗体
MDI.Show
'卸载登陆窗体
Unload Me
End Sub
Private Sub Form_Load()
Call ScreenCenter(Me)
‘调用标准模块中的ScreenCenter过程，将本窗体置于屏幕中心
‘连接d:\VB\CH12\Mydata.mdb，连接对象为conn。
Dim conns As String
conns = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\VB\CH12\Mydata.mdb"
conn.Open conns
End Sub
Private Sub txtPassword_KeyPress(KeyAscii As Integer)
'用于在输入完密码后并按回车键后跳到确定命令按钮
If KeyAscii = 13 Then cmdOK.SetFocus
End Sub
Private Sub txtUserName_KeyPress(KeyAscii As Integer)
'用于在输入完用户名后并按回车键后跳到输入密码文本框
If KeyAscii = 13 Then txtPassword.SetFocus
End Sub
12.4.3
Private Sub Add_user_Click()
Adduser.Show ‘调入“新建用户”窗体
End Sub
Private Sub ck_Click()
crk1.Caption = "出库"
crk1.Show ‘调入“出入库”窗体
End Sub
Private Sub ckhwmx_Click()
sqlfind = "select * from 出入库"
rs_data1.Open sqlfind,conn,adOpenKeyset,adLockPessimistic
hwckmx.Show ‘调入“查看货物明细”窗体
End Sub
Private Sub hwcx_Click()
cxhw.Show ‘调入“查询货物”窗体
End Sub
Private Sub Hz_date_Click()
hz_menu = "date"
hzhw.Show ‘调入“汇总货物”窗体，并按日期汇总
End Sub
Private Sub Hz_hdh_Click()
hz_menu = "hdh"
hzhw.Show ‘调入“汇总货物”窗体，并按货单号汇总
End Sub
Private Sub quit_Click()
Unload Me
End Sub
Private Sub rk_Click()
crk1.Caption = "入库"
crk1.Show ‘调入“出入库”窗体
End Sub
Private Sub Hz_kh_Click()
hz_menu = "kh"
hzhw.Show ‘调入“汇总货物”窗体，并按客户汇总
End Sub
Private Sub XGMM_Click()
pwsxg.Show ‘调入“修改密码”窗体
End Sub
12.4.4
Private Sub Command1_Click()
Dim sql As String
Dim rs_add As New ADODB.Recordset
If Trim(Text1.Text) = "" Then
MsgBox "用户名不能为空",vbOKOnly + vbExclamation,""
Exit Sub
Text1.SetFocus
Else
If Trim(Text2.Text) = "" Then
MsgBox "密码不能为空",vbOKOnly + vbExclamation,""
Exit Sub
Text2.SetFocus
Else
sql = "select * from 用户表"
rs_add.Open sql,conn,adOpenKeyset,adLockPessimistic
While (rs_add.EOF = False)
If Trim(rs_add.Fields(0)) = Trim(Text1.Text) Then
MsgBox "已有这个用户",vbOKOnly + vbExclamation,""
Text1.SetFocus
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Combo1.Text = ""
Exit Sub
Else
rs_add.MoveNext
End If
Wend
If Trim(Text2.Text) <> Trim(Text3.Text) Then
MsgBox "两次密码不一致",vbOKOnly + vbExclamation,""
Text2.SetFocus
Text2.Text = ""
Text3.Text = ""
Exit Sub
ElseIf Trim(Combo1.Text) <> "system" And Trim(Combo1.Text) <> "user" Then
MsgBox "请选择正确的用户权限",vbOKOnly + vbExclamation,""
Combo1.SetFocus
Combo1.Text = ""
Exit Sub
Else
rs_add.AddNew
rs_add.Fields(0) = Text1.Text
rs_add.Fields(1) = Text2.Text
rs_add.Fields(2) = Combo1.Text
rs_add.Update
rs_add.Close
MsgBox "添加用户成功",vbOKOnly + vbExclamation,""
Unload Me
End If
End If
End If
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
12.4.5
Private Sub Command1_Click()
If Trim(Text1.Text = "") Then
MsgBox "旧密码不能为空，请重新输入！",vbOKOnly + vbExclamation,"警告"
Text1.SetFocus
Text1.Text = ""
Exit Sub
End If
If Trim(Text2.Text = "") Then
MsgBox "新密码不能为空，请重新输入！",vbOKOnly + vbExclamation,"警告"
Text2.SetFocus
Text2.Text = ""
Exit Sub
End If
If Text2.Text <> Text3.Text Then
MsgBox "两次输入的新密码不同，请重新输入！",vbOKOnly + vbExclamation,"警告"
Text2.SetFocus
Text2.Text = ""
Text3.Text = ""
Exit Sub
End If
Dim strSql As String
Dim rs As New ADODB.Recordset
strSql = "Select * from 用户表 where 用户名 = '" & userid & "'"
rs.Open strSql,conn,adOpenForwardOnly,adLockReadOnly
If Trim(rs.Fields("密码")) <> Trim(Text1.Text) Then
MsgBox "旧密码不对，请重新输入！",vbOKOnly + vbExclamation,"警告"
Text1.SetFocus
Text1.Text = ""
Else
strSql = "Update 用户表 set 密码='" & Text2 & "' where 用户名= '" & userid & "'"
conn.Execute strSql
MsgBox "密码修改成功！",vbOKOnly + vbInformation,"提示"
Text3.Text = ""
Text1.Text = ""
Text2.Text = ""
Unload Me
End If
rs.Close
Set rs = Nothing
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
12.4.6
Option Explicit
Const row_num = 10 '表格行数
Const col_num = 6 '表格列数
Private Sub Combo2_Click()
MSFlexGrid1.Text = Combo2.Text
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
Combo2.Visible = False
Text5.Visible = True
nextposition MSFlexGrid1.Row,MSFlexGrid1.Col
End Sub
Private Sub Command1_Click()
Dim rs_save As New ADODB.Recordset
Dim sql As String
Dim i As Integer
Dim s As String '转化数据用
On Error GoTo saveerror
If Trim(Text1.Text) = "" Then
MsgBox "货单不能为空!",vbOKOnly + vbExclamation,""
Text1.SetFocus
Exit Sub
End If
If Combo1.Text = "" Then
MsgBox "请选择货源地！",vbOKOnly + vbExclamation,""
Combo1.SetFocus
Exit Sub
End If
If comboy.Text = "" Then
MsgBox "请选择年份！",vbOKOnly + vbExclamation,""
comboy.SetFocus
Exit Sub
End If
If combom.Text = "" Then
MsgBox "请选择月份！",vbOKOnly + vbExclamation,""
combom.SetFocus
Exit Sub
End If
If combod.Text = "" Then
MsgBox "请选择日期！",vbOKOnly + vbExclamation,""
combod.SetFocus
Exit Sub
End If
If Text2.Text = "" Then
MsgBox "请填写凭证号！",vbOKOnly + vbExclamation,""
Text2.SetFocus
Exit Sub
End If
If Text3.Text = "" Then
MsgBox "请填写经手人！",vbOKOnly + vbExclamation,""
Text3.SetFocus
Exit Sub
End If
If MSFlexGrid1.Col <> 0 Then
MsgBox "请输入完整的物品信息！",vbOKOnly + vbExclamation,""
MSFlexGrid1.SetFocus
Exit Sub
End If
sql = "select * from 出入库 where 货单号='" & Text1.Text & "'"
rs_save.Open sql,conn,adOpenKeyset,adLockPessimistic
If rs_save.EOF Then
rs_save.AddNew
rs_save.Fields(0) = Trim(Text1.Text)
rs_save.Fields(1) = CDate(Trim(comboy.Text) & "-" & Trim(combom.Text) & "-" & Trim(combod.Text))
rs_save.Fields(2) = Trim(Combo1.Text)
rs_save.Fields(3) = Trim(Text2.Text)
rs_save.Fields(4) = Trim(Text3.Text)
rs_save.Fields(5) = Trim(Text4.Text)
If crk1.Caption = "入库" Then '出入库标记
rs_save.Fields(6) = True
Else
rs_save.Fields(6) = False
End If
rs_save.Update
rs_save.Close
Else
MsgBox "货单号重复！",vbOKOnly + vbExclamation,""
Text1.SetFocus
Text1.Text = ""
rs_save.Close
Exit Sub
End If
sql = "select * from 货物明细"
rs_save.Open sql,conn,adOpenKeyset,adLockPessimistic
For i = 1 To MSFlexGrid1.Row - 1
rs_save.AddNew
rs_save.Fields(0) = Trim(Text1.Text)
rs_save.Fields(1) = CDate(Trim(comboy.Text) & "-" & Trim(combom.Text) & "-" & Trim(combod.Text))
rs_save.Fields(2) = Trim(Combo1.Text)
MSFlexGrid1.Row = i
MSFlexGrid1.Col = 0
rs_save.Fields(3) = Trim(MSFlexGrid1.Text)
MSFlexGrid1.Col = 1
If crk1.Caption = "出库" Then
s = "-" & Trim(MSFlexGrid1.Text)
rs_save.Fields(4) = CDbl(s)
Else
rs_save.Fields(4) = CDbl(Trim(MSFlexGrid1.Text))
End If
MSFlexGrid1.Col = 2
rs_save.Fields(5) = Trim(MSFlexGrid1.Text)
MSFlexGrid1.Col = 3
rs_save.Fields(6) = Trim(MSFlexGrid1.Text)
MSFlexGrid1.Col = 4
If crk1.Caption = "出库" Then
s = "-" & Trim(MSFlexGrid1.Text)
rs_save.Fields(7) = CDbl(s)
Else
rs_save.Fields(7) = CDbl(Trim(MSFlexGrid1.Text))
End If
MSFlexGrid1.Col = 5
rs_save.Fields(8) = Trim(MSFlexGrid1.Text)
Next i
rs_save.Update
rs_save.Close
MsgBox "添加成功！",vbOKOnly + vbExclamation,""
Unload Me
Exit Sub
saveerror:
MsgBox Err.Description
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim sql As String
Dim i As Integer
On Error GoTo loaderror
Combo1.AddItem ("北京")
Combo1.AddItem ("上海")
Combo1.AddItem ("天津")
Combo1.AddItem ("武汉")
Combo1.AddItem ("广州")
Combo1.AddItem ("南京")
Combo2.AddItem ("微利公司")
Combo2.AddItem ("火星公司")
Combo2.AddItem ("南山公司")
Combo2.AddItem ("长虹公司")
Combo2.AddItem ("利得公司")
For i = 2007 To 2020 '添加月份
comboy.AddItem i
Next i
For i = 1 To 12 '添加月份
combom.AddItem i
Next i
For i = 1 To 31 '添加日期
combod.AddItem i
Next i
setgrid
setgrid_head
Text5.Visible = False
clear_grid
Exit Sub
loaderror:
MsgBox Err.Description
End Sub
Private Sub Form_Unload(Cancel As Integer)
'关闭数据对象
'rs_checkname.Close
'rs_custom.Close
End Sub
Public Sub setgrid() '设置表格子程序
Dim i As Integer
On Error GoTo seterror
MSFlexGrid1.ScrollBars = flexScrollBarBoth
MSFlexGrid1.FixedCols = 0
MSFlexGrid1.Rows = row_num
MSFlexGrid1.Cols = col_num
MSFlexGrid1.SelectionMode = flexSelectionByRow
For i = 0 To row_num - 1
MSFlexGrid1.RowHeight(i) = 315
Next
For i = 0 To col_num - 1
MSFlexGrid1.ColWidth(i) = 1300
Next i
Exit Sub
seterror:
MsgBox Err.Description
End Sub
Public Sub setgrid_head()
On Error GoTo setheaderror
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "物品名称"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = " 单价"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "数量"
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "单位"
MSFlexGrid1.Col = 4
MSFlexGrid1.Text = " 金额"
MSFlexGrid1.Col = 5
MSFlexGrid1.Text = "客户名"
Exit Sub
setheaderror:
MsgBox Err.Description
End Sub
Public Sub clear_grid()
Dim i As Integer,j As Integer
For i = 1 To row_num - 1
MSFlexGrid1.Row = i
For j = 0 To col_num - 1
MSFlexGrid1.Col = j
MSFlexGrid1.Text = ""
Next j
Next i
End Sub
Public Sub nextposition(ByVal r As Integer,ByVal c As Integer)
On Error GoTo nexterror
Text5.Width = MSFlexGrid1.CellWidth
Text5.Height = MSFlexGrid1.CellHeight
Text5.Left = MSFlexGrid1.Left + MSFlexGrid1.ColPos(c)
Text5.Top = MSFlexGrid1.Top + MSFlexGrid1.RowPos(r)
Text5.Text = MSFlexGrid1.Text
Text5.Visible = True
Text5.SetFocus
Exit Sub
nexterror:
MsgBox Err.Description
End Sub
Private Sub MSFlexGrid1_Click()
If Combo2.Visible = True Then
Exit Sub
End If
nextposition MSFlexGrid1.Row,MSFlexGrid1.Col
End Sub
Private Sub Text5_KeyPress(KeyAscii As Integer)
Dim i As Integer,j As Integer
Dim price As Double,coun As Integer
On Error GoTo texterror
If KeyAscii = 13 Then
MSFlexGrid1.Text = Text5.Text
i = MSFlexGrid1.Row
j = MSFlexGrid1.Col
If j = 0 And Trim(Text5.Text) = "" Then
MsgBox "物品名称不能为空",vbOKOnly + vbExclamation,""
Text5.SetFocus
Exit Sub
End If
If j = 1 And Not IsNumeric(Text5.Text) Then
MsgBox "单价请输入数字！",vbOKOnly + vbExclamation,""
Text5.SetFocus
Exit Sub
End If
If j = 2 And Not IsNumeric(Text5.Text) Then
MsgBox "数量请输入数字！",vbOKOnly + vbExclamation,""
Text5.SetFocus
Exit Sub
End If
If j = 3 And Trim(Text5.Text) = "" Then
MsgBox "单位不能为空！",vbOKOnly + vbExclamation,""
Text5.SetFocus
Exit Sub
End If
If j = 3 And Not IsNull(Text5.Text) Then
MSFlexGrid1.Col = 1 '金额由程序算出
price = CDbl(MSFlexGrid1.Text)
MSFlexGrid1.Col = 2
coun = CInt(MSFlexGrid1.Text)
MSFlexGrid1.Col = 4
MSFlexGrid1.Text = price * coun
MSFlexGrid1.Col = MSFlexGrid1.Col + 1
Text5.Visible = False
setcombo2 MSFlexGrid1.Row,MSFlexGrid1.Col
KeyAscii = 0
Exit Sub
End If
MSFlexGrid1.Col = MSFlexGrid1.Col + 1
KeyAscii = 0
nextposition MSFlexGrid1.Row,MSFlexGrid1.Col
End If
Exit Sub
texterror:
MsgBox Err.Description
End Sub
Public Sub setcombo2(ByVal r As Integer,ByVal c As Integer)
On Error GoTo seterror
Combo2.Width = MSFlexGrid1.CellWidth
Combo2.Left = MSFlexGrid1.Left + MSFlexGrid1.ColPos(c)
Combo2.Top = MSFlexGrid1.Top + MSFlexGrid1.RowPos(r)
Combo2.Text = MSFlexGrid1.Text
Combo2.Visible = True
Combo2.SetFocus
Exit Sub
seterror:
MsgBox Err.Description
End Sub
12.4.7
Option Explicit
Dim rs_data2 As New ADODB.Recordset
Dim select_row As String
Dim showgrid2 As Boolean
Private Sub Form_Load()
On Error GoTo loaderror
displaygrid1 '调用显示Datagrid1子程序
setgrid2head
loaderror:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
Public Sub displaygrid1() '显示msflexgrid1子程序
Dim i As Integer
On Error GoTo displayerror
setgrid
setgridhead
MSFlexGrid1.Row = 0
If Not rs_data1.EOF Then
rs_data1.MoveFirst
Do While Not rs_data1.EOF
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
If Not IsNull(rs_data1.Fields(0)) Then MSFlexGrid1.Text = rs_data1.Fields(0) Else MSFlexGrid1.Text = ""
MSFlexGrid1.Col = 1
If Not IsNull(rs_data1.Fields(1)) Then MSFlexGrid1.Text = rs_data1.Fields(1) Else MSFlexGrid1.Text = ""
MSFlexGrid1.Col = 2
If Not IsNull(rs_data1.Fields(2)) Then MSFlexGrid1.Text = rs_data1.Fields(2) Else MSFlexGrid1.Text = ""
MSFlexGrid1.Col = 3
If Not IsNull(rs_data1.Fields(3)) Then MSFlexGrid1.Text = rs_data1.Fields(3) Else MSFlexGrid1.Text = ""
MSFlexGrid1.Col = 4
If Not IsNull(rs_data1.Fields(4)) Then MSFlexGrid1.Text = rs_data1.Fields(4) Else MSFlexGrid1.Text = ""
MSFlexGrid1.Col = 5
If Not IsNull(rs_data1.Fields(5)) Then MSFlexGrid1.Text = rs_data1.Fields(5) Else MSFlexGrid1.Text = ""
MSFlexGrid1.Col = 6
If rs_data1.Fields(6) = True Then MSFlexGrid1.Text = "入库" Else MSFlexGrid1.Text = "出库"
rs_data1.MoveNext
Loop
End If
displayerror:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
Public Sub setgrid()
Dim i As Integer
On Error GoTo seterror
With MSFlexGrid1
,ScrollBars = flexScrollBarBoth
,FixedCols = 0
,Rows = rs_data1.RecordCount + 1
,Cols = 7
,SelectionMode = flexSelectionByRow
For i = 0 To,Rows - 1
,RowHeight(i) = 315
Next
For i = 0 To,Cols - 1
,ColWidth(i) = 1300
Next i
End With
Exit Sub
seterror:
MsgBox Err.Description
End Sub
Public Sub setgridhead()
On Error GoTo setheaderror
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "货单号"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = "日期"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "货源地"
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "编号"
MSFlexGrid1.Col = 4
MSFlexGrid1.Text = " 经手人"
MSFlexGrid1.Col = 5
MSFlexGrid1.Text = "备注"
MSFlexGrid1.Col = 6
MSFlexGrid1.Text = "出入库"
Exit Sub
setheaderror:
MsgBox Err.Description
End Sub
Private Sub MSFlexGrid1_Click()
On Error GoTo griderror
Dim getrow As Long
If showgrid2 = True Then
rs_data2.Close
End If
getrow = MSFlexGrid1.Row
If MSFlexGrid1.Rows = 1 Then
MsgBox "无相关纪录",vbOKOnly + vbExclamation,""
Else
select_row = MSFlexGrid1.TextMatrix(getrow,0)
displaygrid2
End If
griderror:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
Public Sub displaygrid2()
Dim sql As String
Dim i As Integer
On Error GoTo displaybasicerror
sql = "select * from 货物明细 where 货单号=" & "'" & select_row & "'"
rs_data2.Open sql,conn,adOpenKeyset,adLockPessimistic
showdata
showgrid2 = True
Exit Sub
displaybasicerror:
MsgBox Err.Description
End Sub
Public Sub setgrid2head()
Dim i As Integer
On Error GoTo set2error
With MSFlexGrid2
,ScrollBars = flexScrollBarBoth
,FixedCols = 0
,Cols = 9
,SelectionMode = flexSelectionByRow
For i = 0 To,Rows - 1
,RowHeight(i) = 315
Next
For i = 0 To,Cols - 1
,ColWidth(i) = 1000
Next i
,Row = 0
,Col = 0
,Text = "货单号"
,Col = 1
,Text = "日期"
,Col = 2
,Text = "货源地"
,Col = 3
,Text = "物品名称"
,Col = 4
,Text = "单价"
,Col = 5
,Text = "数量"
,Col = 6
,Text = "单位"
,Col = 7
,Text = "金额"
,Col = 8
,Text = "客户名"
End With
Exit Sub
set2error:
MsgBox Err.Description
End Sub
Public Sub showdata()
With MSFlexGrid2
.Rows = rs_data2.RecordCount + 1
,Row = 0
'rs_data2.RecordCount.Open
'MSFlexGrid2.Rows = rs_data2.RecordCount + 1
'MSFlexGrid2.Row = 0
If Not rs_data2.EOF Then
rs_data2.MoveFirst
Do While Not rs_data2.EOF
,Row =,Row + 1
,Col = 0
If Not IsNull(rs_data2.Fields(0)) Then,Text=rs_data2.Fields(0) Else,Text = ""
,Col = 1
If Not IsNull(rs_data2.Fields(1)) Then,Text=rs_data2.Fields(1) Else,Text = ""
,Col = 2
If Not IsNull(rs_data2.Fields(2)) Then,Text=rs_data2.Fields(2) Else,Text = ""
,Col = 3
If Not IsNull(rs_data2.Fields(3)) Then,Text=rs_data2.Fields(3) Else,Text = ""
,Col = 4
If Not IsNull(rs_data2.Fields(4)) And CDbl(rs_data2.Fields(4)) < 0 Then
,Text = -CDbl(rs_data2.Fields(4))
Else
,Text = rs_data2.Fields(4)
End If
,Col = 5
If Not IsNull(rs_data2.Fields(5)) Then,Text=rs_data2.Fields(5) Else,Text = ""
,Col = 6
If Not IsNull(rs_data2.Fields(6)) Then,Text=rs_data2.Fields(6) Else,Text = ""
,Col = 7
If Not IsNull(rs_data2.Fields(7)) And CDbl(rs_data2.Fields(4)) < 0 Then
,Text = -CDbl(rs_data2.Fields(7))
Else
,Text = rs_data2.Fields(7)
End If
,Col = 8
If Not IsNull(rs_data2.Fields(8)) Then,Text=rs_data2.Fields(8) Else,Text = ""
rs_data2.MoveNext
Loop
rs_data2.MoveLast
End If
End With
End Sub
Public Sub nextpos(ByVal r As Integer,ByVal c As Integer)
On Error GoTo nexterror
Text1.Width = MSFlexGrid2.CellWidth
Text1.Height = MSFlexGrid2.CellHeight
Text1.Left = MSFlexGrid2.Left + MSFlexGrid2.ColPos(c)
Text1.Top = MSFlexGrid2.Top + MSFlexGrid2.RowPos(r)
Text1.Text = MSFlexGrid2.Text
Text1.Visible = True
Text1.SetFocus
Exit Sub
nexterror:
MsgBox Err.Description
End Sub
Private Sub Form_Unload(Cancel As Integer)
findok = False
rs_data1.Close
Set rs_data1 = Nothing
End Sub
12.4.8
Option Explicit
Dim rs_find As New ADODB.Recordset
Private Sub Command1_Click()
On Error GoTo cmderror
Dim find_date1 As String
Dim find_date2 As String
If Option1.Value = True Then
sqlfind = "select * from 出入库 where 货单号 between '" & _
Combo1(0).Text & "'" & " and " & "'" & Combo1(1).Text & "'"
End If
If Option2.Value = True Then
find_date1 = Format(CDate(comboy(0).Text & "-" & _
combom(0).Text & "-" & combod(0).Text),"yyyy-mm-dd")
find_date2 = Format(CDate(comboy(1).Text & "-" & _
combom(1).Text & "-" & combod(1).Text),"yyyy-mm-dd")
sqlfind = "select * from 出入库 where 日期 between #" & _
find_date1 & "#" & " and" & " #" & find_date2 & "#"
End If
rs_data1.Open sqlfind,conn,adOpenKeyset,adLockPessimistic
hwckmx.displaygrid1
Unload Me
hwckmx.Show
cmderror:
If Err.Number <> 0 Then
MsgBox "请输入正确的查询条件！",vbOKOnly + vbExclamation,"警告"
End If
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim i As Integer
Dim j As Integer
Dim sql As String
'If findok = True Then
'rs_data1.Close
'End If
sql = "select * from 出入库 order by 货单号 desc"
rs_find.CursorLocation = adUseClient
rs_find.Open sql,conn,adOpenKeyset,adLockPessimistic
If rs_find.EOF = False Then '添加货单号
With rs_find
Do While Not,EOF
Combo1(0).AddItem,Fields(0)
Combo1(1).AddItem,Fields(0)
,MoveNext
Loop
End With
End If
For i = 2007 To 2020 '添加年
comboy(0).AddItem i
comboy(1).AddItem i
Next i
For i = 1 To 12 '添加月
combom(0).AddItem i
combom(1).AddItem i
Next i
For i = 1 To 31 '添加日
combod(0).AddItem i
combod(1).AddItem i
Next i
End Sub
Private Sub Form_Unload(Cancel As Integer)
rs_find.Close
End Sub
Private Sub Option1_Click()
Option2.Value = False
End Sub
Private Sub Option2_Click()
Option1.Value = False
End Sub
12.4.9
Option Explicit
Dim rs_sum As New ADODB.Recordset
Dim addup As Double
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim sql As String
Select Case hz_menu
Case "hdh" '按货单号汇总
Label1.Caption = "按货单号汇总"
sql="select 货源地,sum(金额) as 总金额 from 货物明细 group by 货源地 order by sum(金额)"
rs_sum.CursorLocation = adUseClient
rs_sum.Open sql,conn,adOpenKeyset,adLockPessimistic
addup = 0
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Cols = 3
' 设置表头
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "货源地"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = "总金额"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "出入库"
If rs_sum.EOF = False Then
rs_sum.MoveFirst
Do While Not rs_sum.EOF
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = rs_sum.Fields(0)
MSFlexGrid1.Col = 1
If CDbl(rs_sum.Fields(1)) < 0 Then
MSFlexGrid1.Text = Replace(rs_sum.Fields(1),"-","")
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "出库"
Else
MSFlexGrid1.Text = rs_sum.Fields(1)
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "入库"
End If
addup = addup + CDbl(rs_sum.Fields(1))
rs_sum.MoveNext
Loop
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "(总计)"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = addup
End If
rs_sum.Close
Case "date" '按日期汇总
Label1.Caption = "按日期汇总"
sql = "select 日期,sum(金额) as 总金额 from 货物明细 group by 日期 order by sum(金额)"
rs_sum.CursorLocation = adUseClient
rs_sum.Open sql,conn,adOpenKeyset,adLockPessimistic
addup = 0
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Cols = 3
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "日期"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = "总金额"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "出入库"
If rs_sum.EOF = False Then
rs_sum.MoveFirst
Do While Not rs_sum.EOF
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = rs_sum.Fields(0)
MSFlexGrid1.Col = 1
If CDbl(rs_sum.Fields(1)) < 0 Then
MSFlexGrid1.Text = Replace(rs_sum.Fields(1),"-","")
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "出库"
Else
MSFlexGrid1.Text = rs_sum.Fields(1)
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "入库"
End If
addup = addup + CDbl(rs_sum.Fields(1))
rs_sum.MoveNext
Loop
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "(总计)"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = addup
End If
rs_sum.Close
Case "kh" '按客户汇总
Label1.Caption = "按客户汇总"
sql = "select 客户名,sum(金额) as 总金额 from 货物明细 group by 客户名 order by sum(金额)"
rs_sum.CursorLocation = adUseClient
rs_sum.Open sql,conn,adOpenKeyset,adLockPessimistic
addup = 0
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Cols = 3
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "客户名"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = "总金额"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "出入库"
If rs_sum.EOF = False Then
rs_sum.MoveFirst
Do While Not rs_sum.EOF
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = rs_sum.Fields(0)
MSFlexGrid1.Col = 1
If CDbl(rs_sum.Fields(1)) < 0 Then
MSFlexGrid1.Text = Replace(rs_sum.Fields(1),"-","")
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "出库"
Else
MSFlexGrid1.Text = rs_sum.Fields(1)
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "入库"
End If
addup = addup + CDbl(rs_sum.Fields(1))
rs_sum.MoveNext
Loop
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "(总计)"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = addup
End If
rs_sum.Close
Case "check_date" '按货物+日期汇总
Label1.Caption = "按货物+日期汇总"
sql = "select 货源地,日期,sum(金额) as 总金额 from 货物明细 " & _
"group by 货源地,日期 order by sum(金额)"
rs_sum.CursorLocation = adUseClient
rs_sum.Open sql,conn,adOpenKeyset,adLockPessimistic
addup = 0
MSFlexGrid1.MergeCells = flexMergeRestrictRows
MSFlexGrid1.MergeCol(0) = True
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Cols = 4
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "货源地"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = "日期"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "总金额"
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "出入库"
If rs_sum.EOF = False Then
rs_sum.MoveFirst
Do While Not rs_sum.EOF
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = rs_sum.Fields(0)
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = rs_sum.Fields(1)
MSFlexGrid1.Col = 2
If CDbl(rs_sum.Fields(2)) < 0 Then
MSFlexGrid1.Text = Replace(rs_sum.Fields(2),"-","")
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "出库"
Else
MSFlexGrid1.Text = rs_sum.Fields(2)
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "入库"
End If
addup = addup + CDbl(rs_sum.Fields(2))
rs_sum.MoveNext
Loop
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "(总计)"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = addup
End If
rs_sum.Close
Case "date_custom" '按日期+客户汇总
Label1.Caption = "按客户+日期汇总"
sql = "select 客户名,日期,sum(金额) as 总金额 from 货物明细 " & _
"group by 客户名,日期 order by sum(金额)"
rs_sum.CursorLocation = adUseClient
rs_sum.Open sql,conn,adOpenKeyset,adLockPessimistic
addup = 0
MSFlexGrid1.MergeCells = flexMergeRestrictRows
MSFlexGrid1.MergeCol(0) = True
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Rows = rs_sum.RecordCount + 2
MSFlexGrid1.Cols = 4
MSFlexGrid1.Row = 0
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "客户名"
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = "日期"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = "总金额"
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "出入库"
If rs_sum.EOF = False Then
rs_sum.MoveFirst
Do While Not rs_sum.EOF
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = rs_sum.Fields(0)
MSFlexGrid1.Col = 1
MSFlexGrid1.Text = rs_sum.Fields(1)
MSFlexGrid1.Col = 2
If CDbl(rs_sum.Fields(2)) < 0 Then
MSFlexGrid1.Text = Replace(rs_sum.Fields(2),"-","")
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "出库"
Else
MSFlexGrid1.Text = rs_sum.Fields(2)
MSFlexGrid1.Col = 3
MSFlexGrid1.Text = "入库"
End If
addup = addup + CDbl(rs_sum.Fields(2))
rs_sum.MoveNext
Loop
MSFlexGrid1.Row = MSFlexGrid1.Row + 1
MSFlexGrid1.Col = 0
MSFlexGrid1.Text = "(总计)"
MSFlexGrid1.Col = 2
MSFlexGrid1.Text = addup
End If
rs_sum.Close
End Select
End Sub
12.4.10
Option Explicit
Public bolAuthority As String '保存用户权限（是否为超级用户）
Public conn As New ADODB.Connection '标记连接对象
Public userID As String '标记当前用户ID
Public userpow As String '标记用户权限
Public find As Boolean '标记查询
Public sqlfind As String '查询语句
Public rs_data1 As New ADODB.Recordset
Public findok As Boolean
Public hz_menu As String '标记汇总种类
Public frmdata As Boolean
Public Sub ScreenCenter(fm As Form) '>>置窗体于屏幕中心
Dim mt!,ml!
With fm
mt = (Screen.Height -,Height) * 0.5
ml = (Screen.Width -,Width) * 0.5
,Move ml,mt
End With
End Sub