【例6-1】 编写一个计算阶乘的Sub过程，计算n的阶乘，n由用户输入。
Sub Factorial(x As Integer)
Dim i As Integer
Dim Result As Single
Result = 1
For i = 1 To x
Result = Result * i
Next i
MsgBox Str(x) + "的阶乘为" + Str(Result)
End Sub
Private Sub Form_Click()
Dim n As Integer
n = InputBox("请输入一个数正整数")
Call Factorial(n)
End Sub
【例6-2】 编写Function过程，已知直角三角形两直角边的长度，求第三边（斜边）
的长度。直角边长度由用户输入。
Function Hypotenuse(a As Integer,b As Integer) As Single
Hypotenuse = Sqr(a ^ 2 + b ^ 2)
End Function
Private Sub Form_Click()
Dim Length1 As Integer
Dim Length2 As Integer
Dim Length3 As Integer
Length1 = Val(InputBox("请输入第一个直角边的长度"))
Length2 = Val(InputBox("请输入第二个直角边的长度"))
Length3 = Hypotenuse(Length1,Length2)
MsgBox Str(Length3)
End Sub
【例6-3】 编写一个求最大公约数的函数过程。
Function Hcf(m As Integer,n As Integer) As Integer
Dim r As Integer,c As Integer
If m < n Then
c = m
m = n
n = c
End If
r = m Mod n
Do While r <> 0
m = n
n = r
r = m Mod n
Loop
Hcf = n
End Function
【例6-4】 用函数过程编写程序，求a，b两数中最大数。
Private Function Max(ByVal x As Integer,ByVal y As Integer)
Dim z As Integer
If x < y Then z = x,x = y,y = z
Max = x
TextX.Text = x
TextY.Text = y
End Function
Private Sub Command1_Click()
Dim a As Integer,b As Integer,c As Integer
a = Val(TextA.Text)
b = Val(TextB.Text)
TextMax.Text = Max(a,b)
TextRA.Text = a
TextRB.Text = b
End Sub
【例6-5】 编写一个Function过程，求数组各元素的平均值。
Private Function Average(stu() As Single) As Single
Dim Start As Integer,Finish As Integer
Dim Aver As Single,Sum As Single,n As Integer
Start = LBound(stu)
Finish = UBound(stu)
Sum = 0,n = 0
For i = Start To Finish
Sum = Sum + stu(i)
n = n + 1
Next
Aver = Sum / n
Average = Aver
End Function
【例6-6】 在下例中，如果没有把可选参数传到过程，则使用缺省值。
Sub ListText(x As String,Optional y As String = "可选参数缺省值")
List1.AddItem x
List1.AddItem y
End Sub
Private Sub Command1_Click()
Dim Addstr As String
Addstr = "第一个参数"
Call ListText(Addstr)
End Sub
【例6-7】 编写Function过程，计算任意多个数的累加和。
Function sum(ParamArray arr()) As Single
Dim x As Variant
sum = 0
For Each x In arr
sum = sum + x
Next x
End Function
Private Sub Form_Click()
Dim a As Single,b As Single
a = 15,b = 16
Print "第一次调用，累加和是:"; sum(a,b)
Print "第二次调用，累加和是:"; sum(1,2,3,4,5,6)
End Sub
【例6-8】 编写程序，运行程序时，单击窗体并输入窗体增加的宽度和高度值，改变窗体的大小。
Sub Increase(f1 As Form,a As Single,b As Single)
f1.Width = f1.Width + a
f1.Height = f1.Height + b
End Sub
Private Sub Form_Click()
Dim x As Single,y As Single
x = Val(InputBox("请输入窗体增加的宽度值"))
y = Val(InputBox("请输入窗体增加的高度值"))
Call Increase(Form1,x,y)
End Sub
【例6-9】 全局过程的调用示例。
Public Function Area(x As Single,y As Single) As Single
Area = x * y
End Function
Private Sub Command1_Click(Index As Integer)
Dim a As Single,b As Single
a = Val(Text1(0).Text)
b = Val(Text1(1).Text)
If Index = 0 Then
Label1(0).Caption = Area(a,b)
Else
Label1(1).Caption = Circ(a,b)
End If
End Sub
Private Sub Form_Load()
Form2.Show
End Sub
Private Sub Command1_Click(Index As Integer)
Dim a As Single,b As Single
a = Val(Text1(0).Text)
b = Val(Text1(1).Text)
If Index = 0 Then
Label1(0).Caption = Form1.Area(a,b)
Else
Label1(1).Caption = Circ(a,b)
End If
End Sub
Public Function Circ(x As Single,y As Single) As Single
Circ = 2 * (x + y)
End Function
【例6-10】 在窗体上放一文本框，编写一事件过程，保证在该文本框内只能输入字母，且无论大小写，都要转换成大写字母显示。
Private Sub Text1_KeyPress（KeyAscii As Integer）
Dim str$
If KeyAscii < 65 Or KeyAscii > 122 Then
Beep
KeyAscii = 0
ElseIf KeyAscii >= 65 And KeyAscii <= 90 Then
Text1 = Text1 + Chr（KeyAscii）
Else
str = UCase（Chr（KeyAscii））
KeyAscii = 0
Text1 = Text1 + str
End If
End Sub
【例6-11】 显示所按键的状态，并判断是否是F10键。
Private Sub Text2_KeyDown(KeyCode As Integer,Shift As Integer)
Dim Msg As String
If Shift And vbCtrlMask Then Msg = Msg & ″Ctrl ″
If Shift And vbAltMask Then Msg = Msg & ″Alt ″
If Shift And vbShiftMask Then Msg = Msg & ″Shift ″
If KeyCode = vbKeyF10 Then Msg = Msg & ″F10 ″
Label1.Caption = Msg & KeyCode
End Sub
【例6-12】 随着鼠标的移动，在窗体上写出鼠标的位置
Private Sub Form_MouseMove(Button As Integer,Shift As Integer,X As Single,
Y As Single)
CurrentX = X
CurrentY = Y
Print X; Y
End Sub
【例6-13】 计算组合公式的结果。
Private Function Fact(n As Integer) As Long
Dim f As Long
f = 1
For i = 1 To n
f = f * i
Next i
Fact = f
End Function
Private Function Comb(x As Integer,y As Integer) As Long
Comb = Fact(x) / (Fact(y) * Fact(x - y))
End Function
Private Sub Command1_Click()
Dim n As Integer,m As Integer
m = Val(Text1.Text)
n = Val(Text2.Text)
If m >= n Then
MsgBox "请重新输入数据，并应保证N>M！"
Exit Sub
End If
Label2.Caption = Comb(n,m)
End Sub
【例6-14】 用递归的方法计算n!。
Private Function Fact(n As Integer) As Long
If n > 0 Then
Fact = n * Fact(n - 1)
Else
Fact = 1
End If
End Function
Private Sub Command1_Click()
Dim n As Integer,m As Long
n = Val(Text1.Text)
If n < 0 Then Exit Sub
m = Fact(n)
Label1.Caption = m
End Sub
【例6-15】 Hanoi塔问题：传说印度教的神梵天创造世界时，在印度北部佛教圣地贝拿勒斯圣庙里，安放了一块黄铜板，板上插着三根针，在其中一根针上自下而上放着由大到小的
64个金盘，梵天要求僧侣们坚定不移地按下面规则把64个盘子移到另一根针上.
'Hmove过程
Sub Hmove(getone As String,putone As String)
Dim temp As String
temp = getone & "===>>" & putone & " "
List1.AddItem temp
End Sub
'Hanoi过程
Sub Hanoi(n As Integer,one As String,two As String,three As String)
If n = 1 Then
Call Hmove(one,three)
Else
Call Hanoi(n - 1,one,three,two)
Call Hmove(one,three)
Call Hanoi(n - 1,two,one,three)
End If
End Sub
Private Sub Command1_Click()
Dim m As Integer
List1.Clear
m = Val(Text1.Text)
Call Hanoi(m,"A","B","C")
End Sub
【例6-16】 求2～100以内的质数。
Private Sub Command1_Click()
Cls
Dim m As Integer
For m = 2 To 100
If isPrime(m) Then
Print m,
End If
Next m
End Sub
Function isPrime(n As Integer) As Boolean
Dim i As Integer
isPrime = True
For i = 2 To n - 1
If n Mod i = 0 Then
isPrime = False
Exit For
End If
Next
End Function
【例6-17】 求999以内的完全数。所谓完全数是指这样的自然数：它的各个约数（不包括该数自身）之和等于该数自身。如 28=1+2+4+7+14就是一个完全数。
Private Sub Command1_Click()
Dim n As Integer
For n = 1 To 999
If n = divsum(n) Then Print n
Next
End Sub
Function divsum(n As Integer)
Dim i As Integer
Dim s As Integer
s = 0
For i = 1 To n - 1
If n Mod i = 0 Then s = s + i
Next
divsum = s
End Function
【例6-18】 编写函数，实现一个十进制整数转换成二至十六任意进制的字符
'TranDec()函数将十进制整数(iDec)转换为任意进制(iBase)字符串(strDecR)
Private Function TranDec (ByVal iDec%,ByVal iBase%) As String
Dim iDecR(60) As Integer '存放不断除以某进制基数后得到的余数
Dim iB As Integer,i As Integer
Dim strDecR As String*60 '存放转换成某进制数后的字符串
Dim strBase As String*16 '存放十六进制数的16个符号
StrBase=”0123456789ABCDEF”
i=0
Do While iDec<>0 '不断除以某进制基数取余直到商为0
iDecR(i) = iDec Mod iBase
iDec=iDec\ iBase
i=i+1
Loop
StrDecR=””
i=i-1
Do While i>=0 '形成某进制的字符串
iB=iDecR(i) '将余数转换为对应字符
strDecR=Rtrim$(strDecR)+Mid$( strBase,iB+1,1)
i=i-1
Loop
TranDec= strDecR
End Function
Private Sub Cmdtran_Click()
Dim idec0%,ibase0%
Idec0=Val(Txtdec.Text) '输入十进制正整数
ibase0=Val(TxtR.Text) '输入某进制正整数
If ibase0<2 or ibase0>16 Then
i=MsgBox(“输入的R进制数超出范围”,vbRetryCancel)
If i=vbRetry Then '重新输入
txtR.Text=””
txtR.SetFocus
Else
End '停止运行
End If
End If
St$=”转换结果(”+ txtR.Text +”进制数)”
LblTran.Caption=st$ '换标签随输入的进制改变
TxtDecR.Text=TranDec(idec0,ibase0) '调用转换函数
End Sub
【例6-19】 编写加密和解密的程序，即将输入的一行字符串中的所有字母加密，同时，
加密后还可以进行解密。
Dim strInput As String * 70
Dim Code As String * 70
Dim Record As String * 70
Dim strTemp As String * 1
Dim i As Integer
Dim Length As Integer
Dim iAsc As Integer
Private Sub cmdcls_Click() '清屏事件过程
txtCode.Text = ""
txtRecode.Text = ""
txtInput.Text = ""
End Sub
Private Sub cmdCode_Click() '加密事件过程
strInput = txtInput.Text
i=1
Length = Len(RTrim(strInput))
'去掉字符串右边的空格,求真正的长度
Code=""
Do While (i<=Length)
strTemp=Mid$(strInput,i,1) '取第i个字符
If (strTemp >="A" And strTemp<="Z") Then
'大写字母加序数5加密
iAsc = Asc(strTemp)+5
If iAsc > Asc("Z") Then iAsc=iAsc-26
'加密后字母超过Z
Code=Left$(Code,i-1)+Chr$(iAsc)
ElseIf (strTemp>="a" And strTemp <= "z") Then
iAsc=Asc(strTemp)+5 '小写字母加序数5加密
If iAsc>Asc("z") Then iAsc=iAsc-26
Code=Left$(Code,i-1)+Chr$(iAsc)
Else
'当第i个字符为其他字符时不加密,与加密字符串的前i-1个字符连接
Code=Left$(Code,i-1)+strTemp
End If
i=i+1
Loop
txtcode.Text=Code
End Sub
Private Sub CmdRecode_Click() '解密事件过程
Code=txtcode.Text
i=1
recode=""
Length=Len(RTrim(Code)) '若还未加密,不能解密,出错
If Length=0 Then J=MsgBox("先加密再解密",48,"解密出错")
Do While (i<=Length)
strTemp=Mid$(Code,i,1)
If (strTemp >="A"And strTemp<="Z") Then
iAsc=Asc(strTemp)-5
ElseIf iAsc<Asc("A") Then iAsc=iAsc+26
recode=Left$(recode,i-1)+Chr$(iAsc)
ElseIf (strTemp >="a"And strTemp<="z") Then
iAsc=Asc(strTemp)-5
If iAsc<Asc("a") Then iAsc=iAsc+26
recode=Left$(recode,i-1)+Chr$(iAsc)
Else
recode=Left$(recode,i-1)+strTemp
End If
i=i+1
Loop
txtrecode.Text = recode
End Sub
【例6-20】 顺序查找
Public Sub Search(a(),ByVal key,index%)
Dim i%
For i = LBound(a) To UBound(a)
If key = a(i) Then
' 找到，元素的下标保存在index形参中，结束查找
index = i
Exit Sub
End If
Next i
index = -1 ' 找不到，index形参的值为-1
End Sub
Private Sub Form_Click()
b = Array(1,3,5,7,9,2,4)
k = Val(InputBox("输入要查找的关键值"))
Call Search(b,k,n%)
Print n
End Sub
【例6-21】 二分法查找
' 形参a()有序数组，low、high查找下界、上界，key查找关键值
' index返回结果，查找到关键值在数组中的下标，找不到为-1
Sub birsearch(a(),ByVal low%,ByVal high%,ByVal key,index%)
Dim mid As Integer
mid = (low + high) \ 2 '取查找区间的中点
If a(mid) = key Then
index = mid '查找到，返回查找到的下标
Exit Sub
ElseIf low > high Then ' 二分法查找区间无元素，查找不到
index = -1
Exit Sub
End If
If key < a(mid) Then '查找区间在上半部
high = mid – 1
Else
low = mid + 1 '查找区间在下半部
End If
Call birsearch(a,low,high,key,index) '递归调用查找函数
End Sub
'主调程序调用：
Private Sub Command1_Click( )
Dim b() As Variant
b = Array(5,13,19,21,37,56,64,75,80,88,92)
Call birsearch(b,LBound(b),UBound(b),21,n%)
Print n
End Sub
【例6-22】 假定有数组声明a( 1 to n )的有序数组，在指定位置k(1<=k<=n-1)处插入一个元素，首先把最后一个元素往后移动一个位置，再依次把前一个元素向后移，直到把k个元素移动完毕；这样第k个元素的位置腾出，就可将数据插入。
Private Sub Command1_Click()
Dim a%(1 To 10),i%,k%
For i = 1 To 9 ' 通过程序自动形成有规律的数组
a(i) = (i-1) * 3 + 1
Next i
For k = 1 To 9 ' 查找欲插入数14在数组中的位置
If 14 < a(k) Then Exit For ' 找到插入的位置下标为k
Next k
For i = 9 To k Step-1 ' 从最后元素开始往后移，腾出位置
a(i + 1) = a(i)
Next i
a(k) = 14 ' 数插入
End Sub
【例6-23】 用插入排序法输入不多于20个数，使数组保持递增的序列。
Dim n As Integer '为窗体级变量，保存当前输入数据的个数
'插入过程insert的形参a()保存输入的有序数据，x为待插入的数
Sub insert(a() As Single,ByVal x!)
Dim i%,j%
j = 1
Do While j < n And x > a(j) ' 查找x应插入的位置j
j = j + 1
Loop
For i = n-1 To j Step -1 ' n-j个元素往右移
a(i + 1) = a(i)
Next i
a(j) = x ' x插入数组中的第i个位置
End Sub
Private Sub Text1_keypress(keyascii As Integer)
Static bb!(1 To 20)
Dim i%
If n = 20 Then
MsgBox "数据太多!",1,"警告"
End
End If
If keyascii = 13 Then ' 当按回车，表示一个数输入
n = n + 1
insert bb(),Val(Text1)
'调用insert过程，将输入的数插入到数组中
Picture2.Print Text1 ' 显示刚输入的数
For i = 1 To n ' 显示插入后的有序数组
Picture1.Print bb(i);
Next i
Picture1.Print
Text1 = ""
End If
End Sub
【例6-24】 假设有序的数组为A、B，合并后的数组为C。
Dim A1(),B1(),C1()
Private Sub Form_Click()
Dim i As Integer
'对A，B数组赋初值
A1=Array(2,4,6,8,10)
B1=Array(1,3,5,7,9,11,13,15)
For i = 1 To UBound(A1)
Picture1.Print A1(i);
Next i
For i = 0 To UBound(B1)
Picture2.Print B1(i);
Next i
ReDim C1(UBound(A1)+UBound(B1)+1) '重定义数组C1的大小
End Sub
Private Sub Command1_Click()
Call Merage(A1(),B1(),C1()) '调用合并子过程
For i = 0 To UBound(C1)
Picture3.Print C1(i);
If (i+1)Mod 10 = 0 Then Picture3.Print
Next i
End Sub
Sub Merage*A(),B(0,C()) '合并排序子过程
Dim ia As Integer,ib As Integer,ic As Integer
Dim i As Integer
Do While ia <= UBound(A) And ib <= UBound(B)
If A(ia) < B(ib) Then
C(ic)=A(ia):ia=ia+1
Else
C(ic)=B(ia):ib=ib+1
End If
ic=ic+1
Loop
Do While ia <= UBound(A) 'A数组剩余元素抄入C数组
C（ic）= A（ia）,ia = ia+1,ic = ic+1
Loop
Do While ib <= UBound(B) 'B数组剩余元素抄入C数组
C（ic）= B（ib）,ib = ib+1,ic = ic+1
Loop
End sub
【例6-25】 编写一个英文打字训练的程序，要求如下：
（1）在标签框内随机产生30个字母的范文；
（2）当焦点进入文本框时开始计时，并显示当时的时间；
（3）在文本框中按照产生的范文输入相应的字母；
（4）当输满30个字母时结束计时，禁止向文本框输入内容，并显示打字的速度和正确率。
Private Sub Command1_Click() ' 产生30个字母的范文
Randomize
Text1 = ""
For i = 1 To 30
a = Chr$(Int(Rnd * 26) + 65) ' 随机产生大写字母
Text1 = Text1 + a ' 产生的字母连入范文框
Next i
End Sub
Private Sub Text2_GotFocus()
t = Time ' 输入文本框获得焦点，开始计时
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If Len(Text2) = 30 Then ' 输入满30个字符
t2 = DateDiff("s",t,Time) ' 计算速度
Text3 = t2 & "秒" ' 显示速度
Text2.Locked = True ' 不允许再修改
y = 0,n = 0
For i = 1 To 30 ' 比较正确率
If Mid(Text1,i,1) = Mid(Text2,i,1) Then
y = y + 1
Else
n = n + 1
End If
Next i
y = y / (y + n) * 100
Text4 = y & "%"
End If
End Sub
Sub Factorial(x As Integer)
Dim i As Integer
Dim Result As Single
Result = 1
For i = 1 To x
Result = Result * i
Next i
MsgBox Str(x) + "的阶乘为" + Str(Result)
End Sub
Private Sub Form_Click()
Dim n As Integer
n = InputBox("请输入一个数正整数")
Call Factorial(n)
End Sub
【例6-2】 编写Function过程，已知直角三角形两直角边的长度，求第三边（斜边）
的长度。直角边长度由用户输入。
Function Hypotenuse(a As Integer,b As Integer) As Single
Hypotenuse = Sqr(a ^ 2 + b ^ 2)
End Function
Private Sub Form_Click()
Dim Length1 As Integer
Dim Length2 As Integer
Dim Length3 As Integer
Length1 = Val(InputBox("请输入第一个直角边的长度"))
Length2 = Val(InputBox("请输入第二个直角边的长度"))
Length3 = Hypotenuse(Length1,Length2)
MsgBox Str(Length3)
End Sub
【例6-3】 编写一个求最大公约数的函数过程。
Function Hcf(m As Integer,n As Integer) As Integer
Dim r As Integer,c As Integer
If m < n Then
c = m
m = n
n = c
End If
r = m Mod n
Do While r <> 0
m = n
n = r
r = m Mod n
Loop
Hcf = n
End Function
【例6-4】 用函数过程编写程序，求a，b两数中最大数。
Private Function Max(ByVal x As Integer,ByVal y As Integer)
Dim z As Integer
If x < y Then z = x,x = y,y = z
Max = x
TextX.Text = x
TextY.Text = y
End Function
Private Sub Command1_Click()
Dim a As Integer,b As Integer,c As Integer
a = Val(TextA.Text)
b = Val(TextB.Text)
TextMax.Text = Max(a,b)
TextRA.Text = a
TextRB.Text = b
End Sub
【例6-5】 编写一个Function过程，求数组各元素的平均值。
Private Function Average(stu() As Single) As Single
Dim Start As Integer,Finish As Integer
Dim Aver As Single,Sum As Single,n As Integer
Start = LBound(stu)
Finish = UBound(stu)
Sum = 0,n = 0
For i = Start To Finish
Sum = Sum + stu(i)
n = n + 1
Next
Aver = Sum / n
Average = Aver
End Function
【例6-6】 在下例中，如果没有把可选参数传到过程，则使用缺省值。
Sub ListText(x As String,Optional y As String = "可选参数缺省值")
List1.AddItem x
List1.AddItem y
End Sub
Private Sub Command1_Click()
Dim Addstr As String
Addstr = "第一个参数"
Call ListText(Addstr)
End Sub
【例6-7】 编写Function过程，计算任意多个数的累加和。
Function sum(ParamArray arr()) As Single
Dim x As Variant
sum = 0
For Each x In arr
sum = sum + x
Next x
End Function
Private Sub Form_Click()
Dim a As Single,b As Single
a = 15,b = 16
Print "第一次调用，累加和是:"; sum(a,b)
Print "第二次调用，累加和是:"; sum(1,2,3,4,5,6)
End Sub
【例6-8】 编写程序，运行程序时，单击窗体并输入窗体增加的宽度和高度值，改变窗体的大小。
Sub Increase(f1 As Form,a As Single,b As Single)
f1.Width = f1.Width + a
f1.Height = f1.Height + b
End Sub
Private Sub Form_Click()
Dim x As Single,y As Single
x = Val(InputBox("请输入窗体增加的宽度值"))
y = Val(InputBox("请输入窗体增加的高度值"))
Call Increase(Form1,x,y)
End Sub
【例6-9】 全局过程的调用示例。
Public Function Area(x As Single,y As Single) As Single
Area = x * y
End Function
Private Sub Command1_Click(Index As Integer)
Dim a As Single,b As Single
a = Val(Text1(0).Text)
b = Val(Text1(1).Text)
If Index = 0 Then
Label1(0).Caption = Area(a,b)
Else
Label1(1).Caption = Circ(a,b)
End If
End Sub
Private Sub Form_Load()
Form2.Show
End Sub
Private Sub Command1_Click(Index As Integer)
Dim a As Single,b As Single
a = Val(Text1(0).Text)
b = Val(Text1(1).Text)
If Index = 0 Then
Label1(0).Caption = Form1.Area(a,b)
Else
Label1(1).Caption = Circ(a,b)
End If
End Sub
Public Function Circ(x As Single,y As Single) As Single
Circ = 2 * (x + y)
End Function
【例6-10】 在窗体上放一文本框，编写一事件过程，保证在该文本框内只能输入字母，且无论大小写，都要转换成大写字母显示。
Private Sub Text1_KeyPress（KeyAscii As Integer）
Dim str$
If KeyAscii < 65 Or KeyAscii > 122 Then
Beep
KeyAscii = 0
ElseIf KeyAscii >= 65 And KeyAscii <= 90 Then
Text1 = Text1 + Chr（KeyAscii）
Else
str = UCase（Chr（KeyAscii））
KeyAscii = 0
Text1 = Text1 + str
End If
End Sub
【例6-11】 显示所按键的状态，并判断是否是F10键。
Private Sub Text2_KeyDown(KeyCode As Integer,Shift As Integer)
Dim Msg As String
If Shift And vbCtrlMask Then Msg = Msg & ″Ctrl ″
If Shift And vbAltMask Then Msg = Msg & ″Alt ″
If Shift And vbShiftMask Then Msg = Msg & ″Shift ″
If KeyCode = vbKeyF10 Then Msg = Msg & ″F10 ″
Label1.Caption = Msg & KeyCode
End Sub
【例6-12】 随着鼠标的移动，在窗体上写出鼠标的位置
Private Sub Form_MouseMove(Button As Integer,Shift As Integer,X As Single,
Y As Single)
CurrentX = X
CurrentY = Y
Print X; Y
End Sub
【例6-13】 计算组合公式的结果。
Private Function Fact(n As Integer) As Long
Dim f As Long
f = 1
For i = 1 To n
f = f * i
Next i
Fact = f
End Function
Private Function Comb(x As Integer,y As Integer) As Long
Comb = Fact(x) / (Fact(y) * Fact(x - y))
End Function
Private Sub Command1_Click()
Dim n As Integer,m As Integer
m = Val(Text1.Text)
n = Val(Text2.Text)
If m >= n Then
MsgBox "请重新输入数据，并应保证N>M！"
Exit Sub
End If
Label2.Caption = Comb(n,m)
End Sub
【例6-14】 用递归的方法计算n!。
Private Function Fact(n As Integer) As Long
If n > 0 Then
Fact = n * Fact(n - 1)
Else
Fact = 1
End If
End Function
Private Sub Command1_Click()
Dim n As Integer,m As Long
n = Val(Text1.Text)
If n < 0 Then Exit Sub
m = Fact(n)
Label1.Caption = m
End Sub
【例6-15】 Hanoi塔问题：传说印度教的神梵天创造世界时，在印度北部佛教圣地贝拿勒斯圣庙里，安放了一块黄铜板，板上插着三根针，在其中一根针上自下而上放着由大到小的
64个金盘，梵天要求僧侣们坚定不移地按下面规则把64个盘子移到另一根针上.
'Hmove过程
Sub Hmove(getone As String,putone As String)
Dim temp As String
temp = getone & "===>>" & putone & " "
List1.AddItem temp
End Sub
'Hanoi过程
Sub Hanoi(n As Integer,one As String,two As String,three As String)
If n = 1 Then
Call Hmove(one,three)
Else
Call Hanoi(n - 1,one,three,two)
Call Hmove(one,three)
Call Hanoi(n - 1,two,one,three)
End If
End Sub
Private Sub Command1_Click()
Dim m As Integer
List1.Clear
m = Val(Text1.Text)
Call Hanoi(m,"A","B","C")
End Sub
【例6-16】 求2～100以内的质数。
Private Sub Command1_Click()
Cls
Dim m As Integer
For m = 2 To 100
If isPrime(m) Then
Print m,
End If
Next m
End Sub
Function isPrime(n As Integer) As Boolean
Dim i As Integer
isPrime = True
For i = 2 To n - 1
If n Mod i = 0 Then
isPrime = False
Exit For
End If
Next
End Function
【例6-17】 求999以内的完全数。所谓完全数是指这样的自然数：它的各个约数（不包括该数自身）之和等于该数自身。如 28=1+2+4+7+14就是一个完全数。
Private Sub Command1_Click()
Dim n As Integer
For n = 1 To 999
If n = divsum(n) Then Print n
Next
End Sub
Function divsum(n As Integer)
Dim i As Integer
Dim s As Integer
s = 0
For i = 1 To n - 1
If n Mod i = 0 Then s = s + i
Next
divsum = s
End Function
【例6-18】 编写函数，实现一个十进制整数转换成二至十六任意进制的字符
'TranDec()函数将十进制整数(iDec)转换为任意进制(iBase)字符串(strDecR)
Private Function TranDec (ByVal iDec%,ByVal iBase%) As String
Dim iDecR(60) As Integer '存放不断除以某进制基数后得到的余数
Dim iB As Integer,i As Integer
Dim strDecR As String*60 '存放转换成某进制数后的字符串
Dim strBase As String*16 '存放十六进制数的16个符号
StrBase=”0123456789ABCDEF”
i=0
Do While iDec<>0 '不断除以某进制基数取余直到商为0
iDecR(i) = iDec Mod iBase
iDec=iDec\ iBase
i=i+1
Loop
StrDecR=””
i=i-1
Do While i>=0 '形成某进制的字符串
iB=iDecR(i) '将余数转换为对应字符
strDecR=Rtrim$(strDecR)+Mid$( strBase,iB+1,1)
i=i-1
Loop
TranDec= strDecR
End Function
Private Sub Cmdtran_Click()
Dim idec0%,ibase0%
Idec0=Val(Txtdec.Text) '输入十进制正整数
ibase0=Val(TxtR.Text) '输入某进制正整数
If ibase0<2 or ibase0>16 Then
i=MsgBox(“输入的R进制数超出范围”,vbRetryCancel)
If i=vbRetry Then '重新输入
txtR.Text=””
txtR.SetFocus
Else
End '停止运行
End If
End If
St$=”转换结果(”+ txtR.Text +”进制数)”
LblTran.Caption=st$ '换标签随输入的进制改变
TxtDecR.Text=TranDec(idec0,ibase0) '调用转换函数
End Sub
【例6-19】 编写加密和解密的程序，即将输入的一行字符串中的所有字母加密，同时，
加密后还可以进行解密。
Dim strInput As String * 70
Dim Code As String * 70
Dim Record As String * 70
Dim strTemp As String * 1
Dim i As Integer
Dim Length As Integer
Dim iAsc As Integer
Private Sub cmdcls_Click() '清屏事件过程
txtCode.Text = ""
txtRecode.Text = ""
txtInput.Text = ""
End Sub
Private Sub cmdCode_Click() '加密事件过程
strInput = txtInput.Text
i=1
Length = Len(RTrim(strInput))
'去掉字符串右边的空格,求真正的长度
Code=""
Do While (i<=Length)
strTemp=Mid$(strInput,i,1) '取第i个字符
If (strTemp >="A" And strTemp<="Z") Then
'大写字母加序数5加密
iAsc = Asc(strTemp)+5
If iAsc > Asc("Z") Then iAsc=iAsc-26
'加密后字母超过Z
Code=Left$(Code,i-1)+Chr$(iAsc)
ElseIf (strTemp>="a" And strTemp <= "z") Then
iAsc=Asc(strTemp)+5 '小写字母加序数5加密
If iAsc>Asc("z") Then iAsc=iAsc-26
Code=Left$(Code,i-1)+Chr$(iAsc)
Else
'当第i个字符为其他字符时不加密,与加密字符串的前i-1个字符连接
Code=Left$(Code,i-1)+strTemp
End If
i=i+1
Loop
txtcode.Text=Code
End Sub
Private Sub CmdRecode_Click() '解密事件过程
Code=txtcode.Text
i=1
recode=""
Length=Len(RTrim(Code)) '若还未加密,不能解密,出错
If Length=0 Then J=MsgBox("先加密再解密",48,"解密出错")
Do While (i<=Length)
strTemp=Mid$(Code,i,1)
If (strTemp >="A"And strTemp<="Z") Then
iAsc=Asc(strTemp)-5
ElseIf iAsc<Asc("A") Then iAsc=iAsc+26
recode=Left$(recode,i-1)+Chr$(iAsc)
ElseIf (strTemp >="a"And strTemp<="z") Then
iAsc=Asc(strTemp)-5
If iAsc<Asc("a") Then iAsc=iAsc+26
recode=Left$(recode,i-1)+Chr$(iAsc)
Else
recode=Left$(recode,i-1)+strTemp
End If
i=i+1
Loop
txtrecode.Text = recode
End Sub
【例6-20】 顺序查找
Public Sub Search(a(),ByVal key,index%)
Dim i%
For i = LBound(a) To UBound(a)
If key = a(i) Then
' 找到，元素的下标保存在index形参中，结束查找
index = i
Exit Sub
End If
Next i
index = -1 ' 找不到，index形参的值为-1
End Sub
Private Sub Form_Click()
b = Array(1,3,5,7,9,2,4)
k = Val(InputBox("输入要查找的关键值"))
Call Search(b,k,n%)
Print n
End Sub
【例6-21】 二分法查找
' 形参a()有序数组，low、high查找下界、上界，key查找关键值
' index返回结果，查找到关键值在数组中的下标，找不到为-1
Sub birsearch(a(),ByVal low%,ByVal high%,ByVal key,index%)
Dim mid As Integer
mid = (low + high) \ 2 '取查找区间的中点
If a(mid) = key Then
index = mid '查找到，返回查找到的下标
Exit Sub
ElseIf low > high Then ' 二分法查找区间无元素，查找不到
index = -1
Exit Sub
End If
If key < a(mid) Then '查找区间在上半部
high = mid – 1
Else
low = mid + 1 '查找区间在下半部
End If
Call birsearch(a,low,high,key,index) '递归调用查找函数
End Sub
'主调程序调用：
Private Sub Command1_Click( )
Dim b() As Variant
b = Array(5,13,19,21,37,56,64,75,80,88,92)
Call birsearch(b,LBound(b),UBound(b),21,n%)
Print n
End Sub
【例6-22】 假定有数组声明a( 1 to n )的有序数组，在指定位置k(1<=k<=n-1)处插入一个元素，首先把最后一个元素往后移动一个位置，再依次把前一个元素向后移，直到把k个元素移动完毕；这样第k个元素的位置腾出，就可将数据插入。
Private Sub Command1_Click()
Dim a%(1 To 10),i%,k%
For i = 1 To 9 ' 通过程序自动形成有规律的数组
a(i) = (i-1) * 3 + 1
Next i
For k = 1 To 9 ' 查找欲插入数14在数组中的位置
If 14 < a(k) Then Exit For ' 找到插入的位置下标为k
Next k
For i = 9 To k Step-1 ' 从最后元素开始往后移，腾出位置
a(i + 1) = a(i)
Next i
a(k) = 14 ' 数插入
End Sub
【例6-23】 用插入排序法输入不多于20个数，使数组保持递增的序列。
Dim n As Integer '为窗体级变量，保存当前输入数据的个数
'插入过程insert的形参a()保存输入的有序数据，x为待插入的数
Sub insert(a() As Single,ByVal x!)
Dim i%,j%
j = 1
Do While j < n And x > a(j) ' 查找x应插入的位置j
j = j + 1
Loop
For i = n-1 To j Step -1 ' n-j个元素往右移
a(i + 1) = a(i)
Next i
a(j) = x ' x插入数组中的第i个位置
End Sub
Private Sub Text1_keypress(keyascii As Integer)
Static bb!(1 To 20)
Dim i%
If n = 20 Then
MsgBox "数据太多!",1,"警告"
End
End If
If keyascii = 13 Then ' 当按回车，表示一个数输入
n = n + 1
insert bb(),Val(Text1)
'调用insert过程，将输入的数插入到数组中
Picture2.Print Text1 ' 显示刚输入的数
For i = 1 To n ' 显示插入后的有序数组
Picture1.Print bb(i);
Next i
Picture1.Print
Text1 = ""
End If
End Sub
【例6-24】 假设有序的数组为A、B，合并后的数组为C。
Dim A1(),B1(),C1()
Private Sub Form_Click()
Dim i As Integer
'对A，B数组赋初值
A1=Array(2,4,6,8,10)
B1=Array(1,3,5,7,9,11,13,15)
For i = 1 To UBound(A1)
Picture1.Print A1(i);
Next i
For i = 0 To UBound(B1)
Picture2.Print B1(i);
Next i
ReDim C1(UBound(A1)+UBound(B1)+1) '重定义数组C1的大小
End Sub
Private Sub Command1_Click()
Call Merage(A1(),B1(),C1()) '调用合并子过程
For i = 0 To UBound(C1)
Picture3.Print C1(i);
If (i+1)Mod 10 = 0 Then Picture3.Print
Next i
End Sub
Sub Merage*A(),B(0,C()) '合并排序子过程
Dim ia As Integer,ib As Integer,ic As Integer
Dim i As Integer
Do While ia <= UBound(A) And ib <= UBound(B)
If A(ia) < B(ib) Then
C(ic)=A(ia):ia=ia+1
Else
C(ic)=B(ia):ib=ib+1
End If
ic=ic+1
Loop
Do While ia <= UBound(A) 'A数组剩余元素抄入C数组
C（ic）= A（ia）,ia = ia+1,ic = ic+1
Loop
Do While ib <= UBound(B) 'B数组剩余元素抄入C数组
C（ic）= B（ib）,ib = ib+1,ic = ic+1
Loop
End sub
【例6-25】 编写一个英文打字训练的程序，要求如下：
（1）在标签框内随机产生30个字母的范文；
（2）当焦点进入文本框时开始计时，并显示当时的时间；
（3）在文本框中按照产生的范文输入相应的字母；
（4）当输满30个字母时结束计时，禁止向文本框输入内容，并显示打字的速度和正确率。
Private Sub Command1_Click() ' 产生30个字母的范文
Randomize
Text1 = ""
For i = 1 To 30
a = Chr$(Int(Rnd * 26) + 65) ' 随机产生大写字母
Text1 = Text1 + a ' 产生的字母连入范文框
Next i
End Sub
Private Sub Text2_GotFocus()
t = Time ' 输入文本框获得焦点，开始计时
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If Len(Text2) = 30 Then ' 输入满30个字符
t2 = DateDiff("s",t,Time) ' 计算速度
Text3 = t2 & "秒" ' 显示速度
Text2.Locked = True ' 不允许再修改
y = 0,n = 0
For i = 1 To 30 ' 比较正确率
If Mid(Text1,i,1) = Mid(Text2,i,1) Then
y = y + 1
Else
n = n + 1
End If
Next i
y = y / (y + n) * 100
Text4 = y & "%"
End If
End Sub
