vb初学经典程序示例

VB典型程序！
1、设计采用欧几里德算法求解两个自然数的最大公约数的程序。

Private Sub command1_click()
Dim m As Long, n As Long
Dim r As Long
m = Val(Text1.Text)
n = Val(Text2.Text)
If m < 1 Or n < 1 Then
Text3.Text = "数据错误"
Else
Do
r = m Mod n
m = n
n = r
Loop Until r = 0
Text3.Text = CStr(m)
End If
End Sub
2、从由字母、数字组成的字符串中找出所有大写字母并逆序输出的程序
Private Sub Command1_Click()
Dim s As String, d As String, t As String
Dim i As Integer
Text1.SetFocus
s = Text1.Text
For i = 1 To Len(s)
If Mid(s, i, 1) >= "A" And Mid(s, i, 1) <= "Z" Then
t = t & Mid(s, i, 1)
End If
Next i
For i = Len(t) To 1 Step -1
d = d & Mid(t, i, 1)
Next i
Text2.Text = d
End Sub
3、编写程序，找出所有三位水仙花数。

所谓水仙花，是指各位数字的立方和等于该数本身的数。

例如，153=1^3+5^3+3^3，,所以153是一个水仙花数。

Option Explicit
Private Sub command1_click()
Dim I As Integer, a As Integer, b As Integer, c As Integer
Dim st As String
For a = 1 To 9
For b = 0 To 9
For c = 0 To 9
I = a * 100 + b * 10 + c
If I = a ^ 3 + b ^ 3 + c ^ 3 Then
st = I & "=" & a & "^3+" & b & "^3+" & c & "^3"
List1.AddItem st
End If
Next c
Next b
Next a
End Sub
4、将一个二进制数原码转换成补码。

Option Explicit
Private Sub command1_click()
Dim source As String, I As Integer
Dim D As String * 1
source = Text1.Text
If Mid(source, 1, 1) <> "1" Then
Text2.Text = source
Text3.Text = source
Else
For I = Len(source) To 2 Step -1
If Mid(source, I, 1) = "1" Then
Mid(source, I, 1) = "0"
Else
Mid(source, I, 1) = "1"
End If
Next I
Text2.Text = source
Text3.Text = source
D = "1"
For I = Len(source) To 2 Step -1
If Mid(source, I, 1) = "1" And D = "1" Then
Mid(source, I, 1) = "0"
D = "1"
ElseIf Mid(source, I, 1) = "0" And D = "1" Then
Mid(source, I, 1) = "1"
D = "0"
End If
Next I
Text3.Text = source
End If
End Sub
5、编写程序，随机生成100个两位整数，并统计出其中小于等于40、大于40小于等于70及大于70的数据个数。

Private Sub command1_click()
Dim I As Integer
Dim s As Integer
Dim s1 As Integer
Dim s2 As Integer
Dim s3 As Integer
For I = 1 To 100
s = Int(Rnd * 90 + 10)
Select Case s
Case Is <= 40
s1 = s1 + 1
Case Is <= 70
s2 = s2 + 1
Case Else
s3 = s3 + 1
End Select
Next I
Text1.Text = CStr(s1)
Text2.Text = CStr(s2)
Text3.Text = CStr(s3)
End Sub
6、编写程序，输入正整数n, 求其对应的二进制数。

Private Sub command1_click()
Dim s As String
Dim t As Integer
t = Val(Text1.Text)
Do While t <> 0
s = CStr(t Mod 2) + s
t = t \ 2
Loop
Text2.Text = s
End Sub
7、编写程序，求出100之内的所有勾股数。

所谓勾股数，是指满足条件a^2+b^2=c^2
(a <>b)的自然数。

Private Sub Command1_Click()
Dim a As Integer
Dim b As Integer
Dim c As Integer
For a = 1 To 100
For b = a + 1 To 100
For c = b + 1 To 100
If a ^ 2 + b ^ 2 = c ^ 2 Then
List1.AddItem CStr(c) & "^2=" & CStr(a) & "^2+" & CStr(b) & "^2"
End If
Next c
Next b
Next a
End Sub
8、设计一个用二分法求方程x^3-x^4+4x^2-1=0在区间【0.，1】上的一个实根。

算法提示：若方程f(x)=0在区间【a,b】上有一个实根，则f(a)与f(b)必然异号，即f(a)*f(b)<0;设c= (a+b)/2,若f(a)*f(c)>0,则令a=c,否则令b=c。

当b-c的绝对值小于或等于给定误差要求时，则c就是要求的根。

Private Function f(x As Single) As Double
f = x ^ 3 - x ^ 4 + 4 * x ^ 2 - 1
End Function
Private Sub Command1_Click()
Dim a As Single '
Dim b As Single
Dim c As Single
a = 0:
b = 1
If f(a) * f(b) < 0 Then
Do
c = (a + b) / 2
If f(a) * f(c) > 0 Then
a = c
Else
b = c
End If
Loop Until Abs(b - c) < 0.000001 And f(b) * f(c) < 0
End If
Print c
End Sub
9、找出100以内的所有素数，存放在数组Prime 中，并将所找到的素数按每行10个的形式显示在窗体上。

Option Base 1
Option Explicit
Private Sub form_click()
Dim prime(50) As Integer, I As Integer
Dim k As Integer, m As Integer, j As Integer
prime(1) = 2
m = 1
For I = 3 To 99 Step 2
For k = 2 To Sqr(I)
If I Mod k = 0 Then Exit For
Next k
If k > Sqr(I) Then
m = m + 1
prime(m) = I
End If
Next I
k = 0
For j = 1 To m
k = k + 1
Print prime(j);
If k Mod 10 = 0 Then Print
Next j
End Sub
10、随即生成10个两两互质的数，并按从小到大的顺序存放在listbox中.。

Option Explicit
Private Sub command1_click()
Dim p As Integer, I As Integer, idx As Integer
Dim j As Integer
List1.List(0) = Int(Rnd * (9999 - 1000)) + 1000
Do
p = Int(Rnd * (9999 - 1000)) + 1000
For I = 0 To List1.ListCount - 1
For j = 2 To p
If p Mod j = 0 And List1.List(I) Mod j = 0 Then
Exit For
End If
Next j
If j <= p Then Exit For
Next I
If I > List1.ListCount - 1 Then
idx = 0
Do While p < List1.List(idx)
idx = idx + 1
If idx > List1.ListCount - 1 Then Exit Do
Loop
List1.AddItem p, idx
End If
Loop Until List1.ListCount = 10
End Sub
11、随机生成10个1-99的整数，用选择法对10个数进行排序。

Option Explicit
Option Base 1
Private Sub cmdsort_click()
Dim sort(10) As Integer, temp As Integer
Dim I As Integer, j As Integer
Randomize
For I = 1 To 10
sort(I) = Int(Rnd * (100 - 1)) + 1
Text1 = Text1 & Str(sort(I))
Next I
For I = 1 To 9
For j = I + 1 To 10
If sort(I) > sort(j) Then
temp = sort(I)
sort(I) = sort(j)
sort(j) = temp
End If
Next j
Text2 = Text2 & Str(sort(I))
Next I
Text2 = Text2 & Str(sort(I))
End Sub
12、编写程序实现顺序查找的功能。

Option Explicit
Option Base 1
Dim search As Variant
Private Sub Command2_Click()
Dim I As Integer, find As Integer
Text2 = ""
find = InputBox("输入要查找的数")
For I = 1 To UBound(search)
If search(I) = find Then Exit For
Next I
If I <= UBound(search) Then
Text2 = "要查找的数" & Str(search(I)) & " 是 search(" & Str(I) & ")" Else
Text2 = "在数列中没有找到" & Str(find)
End If
End Sub
Private Sub Command1_Click()
Dim I As Integer, Element As Variant
search = Array(34, 12, 56, 81, 74, 59, 83, 91, 26)
For Each Element In search
Text1 = Text1 & Str(Element)
Next Element
End Sub
13、编写程序实现二分查找功能。

Option Explicit
Option Base 1
Dim search As Variant
Private Sub Command1_Click()
Dim v As Variant
search = Array(12, 17, 23, 28, 30, 39, 41, 46, 57, 61, 78, 83, 85, 89, 93) For Each v In search
Text1 = Text1 & Str(v)
Next v
End Sub
Private Sub Command2_Click()
Dim left As Integer, right As Integer
Dim mid As Integer, flg As Boolean
Dim find As Integer
find = InputBox("输入要查找的数")
left = 1: right = UBound(search)
flg = False
Do While left <= right
mid = (right + left) / 2
If search(mid) = find Then
flg = True
Exit Do
ElseIf find > search(mid) Then
left = mid + 1
Else
right = mid - 1
End If
Loop
If flg Then
Text2 = " 要查找的数" & "在search(" & Str(mid) & ")中" Else
Text2 = Str(find) & "不在数组中"
End If
End Sub
14、设A是3*2的矩阵，B是2*3的矩阵，求A*B。

Option Explicit
Option Base 1
Dim Idx As Integer
Dim A(3, 2) As Integer, B(2, 3) As Integer
Dim C(3, 3) As Integer
Private Sub Command1_Click()
Dim I As Integer, J As Integer
Dim t As Integer
For I = 1 To 3
For J = 1 To 2
A(I, J) = Text1(t)
t = t + 1
Next J
Next I
t = 0
For I = 1 To 2
For J = 1 To 3
B(I, J) = Text2(t)
t = t + 1
Next J
Next I
End Sub
Private Sub Command2_Click()
Dim I As Integer, J As Integer
Dim K As Integer, t As Integer
For I = 1 To 3
For J = 1 To 3
For K = 1 To 2
C(I, J) = C(I, J) + A(I, K) * B(K, J)
Next K
Text3(t) = C(I, J)
t = t + 1
Next J
Next I
End Sub
Private Sub Text1_Change(Index As Integer)
Idx = Idx + 1
If Idx = 6 Then
Text2(0).SetFocus
Idx = 0
Else
Text1(Idx).SetFocus
End If
End Sub
Private Sub Text2_Change(Index As Integer)
Idx = Idx + 1
If Idx = 6 Then
Command1.SetFocus
Idx = 0
Else
Text2(Idx).SetFocus
End If
End Sub
15、求出裴波拉契数列的前18项，并按顺序将它们显示在一个文本框内。

裴波拉契数列的递推公式如下：
1 n=1
F(n)= 1 n=2
F(n-2)+F(n-1) n>=3
Option Base 1
Option Explicit
Private Sub Form_Click()
Dim Fb(18) As Integer, I As Integer
Fb(1) = 1: Fb(2) = 1
For I = 3 To 18
Fb(I) = Fb(I - 2) + Fb(I - 1)
Next I
For I = 1 To 18
Text1 = Text1 & Str(Fb(I)) & ""
Next I
End Sub
16、统计字母（不分大小写）在文本中出现的次数。

Option Explicit
Private Sub Command1_Click()
Dim St As String, Idx As Integer
Dim A(0 To 25) As Integer
Dim I As Integer, Js As Integer
Dim Ch As String * 1, L As Integer
St = Text1.Text
L = Len(St)
For I = 1 To L
Ch = Mid(St, I, 1)
If Ch >= "A" And Ch <= "Z" Then
Idx = Asc(Ch) - Asc("A")
A(Idx) = A(Idx) + 1
ElseIf Ch >= "a" And Ch <= "z" Then
Idx = Asc(Ch) - Asc("a")
A(Idx) = A(Idx) + 1
End If
Next I
For I = 0 To 25
If A(I) <> 0 Then
Js = Js + 1
Text2 = Text2 & Chr(I + Asc("A")) & ":" & Str(A(I)) & ""
If Js Mod 5 = 0 Then Text2 = Text2 & Chr(13) & Chr(10)
End If
Next I
End Sub
17、设有15名学生按照已有的编号顺序围成一圈，1~3报数，凡报到3者出圈，并给他一个新的编号。

最先出圈者新的编号为1 ，第二个出圈者新的编号为2，以此类推，直到所有的学生都重新编号。

将学生的新老编号对应关系打印出来。

Option Base 1
Private Sub Command1_Click()
Dim old_No(15) As Integer, New_No(15) As Integer
Dim I As Integer, Idx As Integer, Count As Integer
For I = 1 To 15
old_No(I) = 1
Next I
Idx = 0
For I = 1 To 15
Count = 0
Do While Count < 3
Idx = Idx + 1
If Idx > 15 Then Idx = 1
Count = old_No(Idx) + Count
Loop
old_No(Idx) = 0
New_No(I) = Idx
Next I
For I = 1 To 15
Text1.Text = Text1.Text & Right(" " & CStr(I), 3)
Text2.Text = Text2.Text & Right(" " & CStr(New_No(I)), 3)
Next I
End Sub
18、找出从1~9这9个数字中任取6个不同数字组成的素数。

Private Sub Command1_Click()
Dim A(0 To 9) As Integer, I As Long, K As Integer
Dim J As Integer, S As String, N As Long
For I = 123456 To 987654
Erase A
A(0) = 1
S = CStr(I)
For J = 1 To 6
K = Val(Mid(S, J, 1))
If A(K) = 0 Then
A(K) = 1
Else
Exit For
End If
Next J
If J > 6 Then
For N = 2 To Sqr(I)
If i Mod N = 0 Then Exit For
Next N
If N > Sqr(I) Then
List1.AddItem I
End If
End If
Next I
End Sub
19、随机生成15个100以内的正整数并显示在一个文本框中，再将所有对称位置的两个数据对调后显示在另一个文本框中（第1个数与第15个数对调，第2个数与第14个数对调，第3个数与第
13个数对调……）.
Option Base 1
Private Sub Command1_Click()
Dim a(15) As Integer
Dim i As Integer
Dim k As Integer
Text1.Text = ""
Text2.Text = ""
Randomize
For i = 1 To 15
a(i) = Int(100 * Rnd + 1)
Text1.Text = Text1.Text & Str(a(i))
Next i
For i = 1 To 7
k = a(i)
a(i) = a(16 - i)
a(16 - i) = k
Next i
For i = 1 To 15
Text2.Text = Text2.Text & Str(a(i))
Next i
End Sub
20、随机生成20个100以内的两位正整数，统计其中有多少个不相同的数Option Base 1
Private Sub Command1_Click()
Dim i As Integer
Dim j As Integer
Dim a(20) As Integer
Dim b() As Integer
k = 0
Randomize
Text1.Text = ""
Text2.Text = ""
For i = 1 To 20
a(i) = Int(90 * Rnd + 10)
Text1.Text = Text1.Text & Str(a(i))
Next i
k = k + 1
ReDim Preserve b(k) As Integer
b(k) = a(1)
For i = 2 To 20
For j = 1 To k
If a(i) = b(j) Then Exit For
Next j
If j > k Then
k = k + 1
ReDim Preserve b(k) As Integer
b(k) = a(i)
End If
Next i
Print k
For j = 1 To k
Text2.Text = Text2.Text & Str(b(j))
Next j
End Sub
21、20个两位随机正整数围成一圈，找出每四个相邻数之和中的最大值，并指出是哪四个相邻的数。

Option Base 1
Private Sub command1_click()
Dim i As Integer
Dim a(20) As Integer
Dim k As Integer
Dim j As Integer
Dim m1 As Integer, m2 As Integer, m3 As Integer
Form1.Cls
Text1.Text = ""
Randomize
For i = 1 To 20
a(i) = Int(90 * Rnd + 10)
Text1.Text = Text1.Text & Str(a(i))
Next i
k = a(1) + a(2) + a(3) + a(4)
j = 1
For i = 2 To 20
m1 = i + 1
If m1 > 20 Then m1 = m1 Mod 20
m2 = i + 2
If m2 > 20 Then m2 = m2 Mod 20
m3 = i + 3
If m3 > 20 Then m3 = m3 Mod 20
If a(i) + a(m1) + a(m2) + a(m3) > k Then
k = a(i) + a(m1) + a(m2) + a(m3)
j = i
End If
Next i
Print k, j
End Sub
22、按金字塔形状打印杨辉三角形。

1
1 1
1 2 1
1 3 3 1
1 4 6 4 1
1 5 10 10 5 1
Option Base 1
Private Sub Command1_Click()
Dim a(6, 6) As Integer
Dim i As Integer, j As Integer
For i = 1 To 6
a(i, 1) = 1: a(i, i) = 1
Next i
For i = 3 To 6
For j = 2 To i - 1
a(i, j) = a(i - 1, j - 1) + a(i - 1, j)
Next j
Next i
For i = 1 To 6
Print Space(12 - 2 * i)
For j = 1 To i
Print a(i, j);
Next j
Print
Next i
End Sub
23、编写打印N阶幻阵的程序。

幻阵是由1~N的平方个自然数组成的齐次方阵（N是一个奇数），方阵的每一行、每一列及两条对角线上的元素和相等。

幻阵的编排规律如下（假定幻阵名为A）:
(1) 1 放在中间一行的中间位置。

即I =N,J=(N+1)/2,A(I,J)=1.
(2)下一个数放在前一个数的右下方，即A(I+1,J+1).
(a)若I+1>N,且J+1<=N,则下一个数放在第一行的下一列位置。

(b)若I+1<=N, 且J+1>N，则下一个数放在下一行的第一列位置。

(c)若I+1>N, 且J+1>N，则下一个数放在前一个数的上方位置。

(d)若I+1<=N，J+1<=N，但右下方位置已存放数据，则下一个数放在前一个数的上方。

（3）重复第二步，直到N的平方个数都放入方阵中。

下面是一个3阶幻阵示例：
Dim a(3, 3) As Integer
Dim i As Integer, j As Integer
Dim k As Integer
k = 1: i = 3: j = 2
a(3, 2) = k
Do
k = k + 1
If k >= 10 Then Exit Do
If i + 1 > 3 And j + 1 <= 3 Then
a(1, j + 1) = k
i = 1: j = j + 1
ElseIf i + 1 <= 3 And j + 1 > 3 Then
a(i + 1, 1) = k
i = i + 1: j = 1
ElseIf i + 1 > 3 And j + 1 > 3 Then
a(i - 1, j) = k
i = i - 1
ElseIf i + 1 <= 3 And j + 1 <= 3 Then
If a(i + 1, j + 1) > 0 Then
a(i - 1, j) = k
i = i - 1
Else
a(i + 1, j + 1) = k
i = i + 1: j = j + 1
End If
End If
Loop
For i = 1 To 3
For j = 1 To 3
Print a(i, j);
Next j
Print
Next i
End Sub
24、对N阶方阵A中的与福对角线平行的各条斜线（共有2N-1条，如下图所示）上的元素进
Max以及具有最大值的斜线上的最大元素。

Private Sub Command1_Click()
Dim i As Integer, j As Integer
Dim a(4, 4) As Integer
Dim b(6) As Integer
Dim max As Integer
Dim k As Integer
Dim max1(6) As Integer
Randomize
Form1.Cls
For i = 1 To 4
For j = 1 To 4
a(i, j) = Int(Rnd * 9 + 1)
If i + j = 2 Then
b(1) = b(1) + a(i, j)
If a(i, j) > max1(1) Then max1(1) = a(i, j) End If
If i + j = 3 Then
b(2) = b(2) + a(i, j)
If a(i, j) > max1(2) Then max1(2) = a(i, j) End If
If i + j = 4 Then
b(3) = b(3) + a(i, j)
If a(i, j) > max1(3) Then max1(3) = a(i, j) End If
If i + j = 6 Then
b(4) = b(4) + a(i, j)
If a(i, j) > max1(4) Then max1(4) = a(i, j) End If
If i + j = 7 Then
b(5) = b(5) + a(i, j)
If a(i, j) > max1(5) Then max1(5) = a(i, j) End If
If i + j = 8 Then
b(6) = b(6) + a(i, j)
If a(i, j) > max1(6) Then max1(6) = a(i, j) End If
Print a(i, j);
Next j
Print
Next i
max = b(1)
Print
Print b(1);
For i = 2 To 6
If b(i) > max Then
max = b(i)
k = i
End If
Print b(i);
Next i
Print
Print max, max1(k)
End Sub。