【题目 8 】编一程序，其功能是求出所有分母小于 7 的不可约真分数相乘的积。所有分数每行 5 个显示在一个多行文本框中。

提示： 1. 当分数的分子与分母互质时 , 这个分数称为不可约分数 ; 当分数的分子小于分母时 , 这个分数就成为真分数 .

2. 注意适时对两个分数积进行约分。

【编程要求】

1 ． 编程参考界面如图所示，编程时不得增加或减少界面对象或改变界面对象的种类，窗体及界面元素大小适中，且均可见；

2 ． 按 “ 开始 ” 按钮，则开始运行程序，并将结果按图示格式显示在文本框中；

3 ． 程序中应包含一个求分数积的通用过程。

答：

源程序：

Private Sub Command1_Click()

    Dim a() As Integer, b() As Integer

    Dim i As Integer, j As Integer

    Dim s As Long, t As Long

    Dim st As String, n As Integer

    For i = 2 To 6

        For j = 1 To i - 1

            If fun1(i, j) Then

                n = n + 1   ' 用于控制一行显示五个分数

                k = k + 1

                ReDim Preserve a(k), b(k)

                a(k) = i

                b(k) = j

                st = st & j & "/" & i & "   "

                If n = 5 Then

                    st = st & vbCrLf

                    n = 0

                End If

            End If

        Next j

    Next i

    Call sub2(a, b, s, t)   ' 求分数积 ,S 是分母积 ,T 是分之积

    Call sub1(s, t)

    st = st & vbCrLf & vbCrLf & " 以上分数相乘结果是 :" & t & "/" & s

    Text1 = st

End Sub

 

Private Function fun1(x As Integer, y As Integer) As Boolean    ' 判断分数是否可约

    fun1 = True

    If x > y Then

        Min = y

    Else

        Min = x

    End If

    For i = 2 To Min

        If x Mod i = 0 And y Mod i = 0 Then

            fun1 = False

            Exit Function

        End If

    Next i

End Function

 

Private Sub sub1(x As Long, y As Long)  ' 对两个分数积进行约分

    For i = 2 To y - 1

        If x Mod i = 0 And y Mod i = 0 Then

            x = x \ i

            y = y \ i

        End If

    Next i

End Sub

 

Private Sub sub2(a() As Integer, b() As Integer, s As Long, t As Long)

    s = 1           ' 求分母之积

    For i = 1 To UBound(a)

        s = s * a(i)

    Next i

    t = 1           ' 求分子之积

    For i = 1 To UBound(b)

        t = t * b(i)

    Next i

End Sub

 

【题目 9 】本程序的功能是：找出 100 以内等于若干相连素数之和的素数。

答：

源程序：

Option Base 1

Private Sub command1_Click()

    Dim p(25) As Integer, i As Integer, n As Integer

    Dim s As String, j As Integer

    For i = 2 To 100

        For n = 2 To Sqr(i)

            If i Mod n = 0 Then Exit For

        Next n

        If n > Sqr(i) Then

            j = j + 1

            p(j) = i

        End If

    Next i

    For i = 3 To UBound(p)

        s = ""

        If fun(i, p, s) Then

            s = CStr(p(i)) & "=" & s

            List1.AddItem s

           

        End If

    Next i

End Sub

 

Private Function fun(n As Integer, p() As Integer, s As String) As Boolean

    Dim j As Integer, sum As Integer, k As Integer

    k = 1

    j = 1

    Do While k < n

        sum = sum + p(k)

        s = s & CStr(p(k))

        If sum > p(n) Then

            j = j + 1

            k = j

            s = ""

            sum = 0

        ElseIf sum < p(n) Then

            k = k + 1

            s = s & "+"

        Else

            fun = True

            Exit Function

        End If

    Loop

End Function

 

【题目 10 】编写程序，验证：对任意一个三个数字不全部相同的三位正整数，有这三个数字组成的最大数减去最小数，得到新的数，对新的数重复进行上述处理，最后总能得到 495 。

【编程要求】

1 ．程序参考界面如图所示，编程时不得不增加或减少界面对象或改变对象的种类，窗体及界面元素大小适中，且均可见；

2 ．运行程序时，在文本框中输入需要验证的三个数，按 “ 验证 ” 按钮，如果输入的三个数个位数字均相等（例如输入 222 ），利用 MsgBox 给出出错信息，程序结束；若输入数据合法，则在列表框中显示验证过程；按 “ 清除 ” 按钮，则将文本框、列表框清空，将焦点至于文本框上；

3 ．程序中应定义一个求给定三位数的数字重新排列得到的最大和最小数的通用过程。

答：

源程序：

Private Sub command1_Click()

    Dim n As Integer, max As Integer, min As Integer

    If Len(Text1) = 3 Then

        If Mid(Text1.Text, 1, 1) = Mid(Text1.Text, 2, 1) _

        And Mid(Text1.Text, 1, 1) = Mid(Text1.Text, 3, 1) Then

            MsgBox Text1.Text & " 数据错误 !", vbOKOnly, " 工程 1"

           End

        Else

            n = Val(Text1)

            Do

                Call sub1(n, max, min)

                List1.AddItem max & "-" & min & "=" & Str(max - min) & vbCrLf

                If max - min <> 495 Then

                    n = max - min

                Else

                    Exit Do

                End If

            Loop

        End If

    End If

End Sub

 

Private Sub sub1(n As Integer, max As Integer, min As Integer)

    Dim a(3) As Integer, sum As String

    For i = 1 To Len(CStr(n))

        a(i) = Mid(CStr(n), i, 1)

    Next i

    For i = 1 To 2

        For j = 2 To 3

            If a(i) < a(j) Then

                temp = a(i)

                a(i) = a(j)

                a(j) = temp

            End If

        Next j

    Next i

    For i = 1 To 3

        sum = sum & CStr(a(i))

    Next i

    max = Val(sum)

    sum = ""

    For i = 3 To 1 Step -1

        sum = sum & CStr(a(i))

    Next i

    min = Val(sum)

End Sub

 

Private Sub Command2_Click()

    Text1 = ""

    List1.Clear

    Text1.SetFocus

End Sub

 

【题目 11 】本程序的功能是：从给定数据范围中找出从左到右，每一位数字都大于等于其后的数字之和的数据（如 84210 就是符合要求的数，因为 8>=4+2+1+0 ， 4>=2+1+0, 2>=1+0,1>=0 ）。

答：

源程序：

Option Explicit

Dim k As Integer

Private Sub Command1_Click()

    Dim i As Long, num() As Integer, sum() As Integer

    Dim flag As Boolean, j As Integer

    For i = 84210 To 90000

        flag = True               

        k = Len(CStr(i))

        ReDim num(k), sum(k)       

        Call lnum(i, num)

        Call lsum(num, sum)

        For j = 1 To k - 1

            If num(j) < sum(j) Then flag = False

        Next j

        If flag Then List1.AddItem CStr(i)

    Next i

End Sub

 

Private Sub lnum(ByVal n As Long, num() As Integer)

    Dim i As Integer, p As Integer

    For i = k To 1 Step -1

        p = n Mod 10

        num(i) = p

        n = n \ 10

    Next i

End Sub

 

Private Sub lsum(n() As Integer, s() As Integer)

    Dim i As Integer, j As Integer

    For i = 1 To k - 1

        For j = i + 1 To k

            s(i) = s(i) + n(j)

        Next j

    Next i

End Sub

 

【题目12】生成 15 个互不相等的两位随机整数放入 a 数组， b 数组用于标记 a 数组中元素的变化趋势，其产生方式如下：

【编程要求】

1 ．程序参考界面如图所示，编程时不得增加或减少界面对象或改变对象的种类，窗体及界面元素大小适中，且均可见；

2 ．按 “ 生成数组 ” 按钮，生成 15 个互不相同的两位随机整数显示在文本框 1 中，并根据题目要求生成 b 数组，按图示格式显示在文本框 2 中。按“清空”按钮，则将 2 个文本框清空；按 “ 退出 ” 按钮，则结束程序运行；

3 ．程序中应定义一个产生数组 b 的通用过程。

答：

源程序：

Option Base 1

Private Sub Command1_Click()

    Dim a(15) As Integer, i As Integer, j As Integer

    Dim b(15) As String, f As Boolean, s As String

    Randomize

    Do

        f = True

        i = i + 1

        x = Int(90 * Rnd) + 10

        For j = 1 To i

            If a(j) = x Then

                i = i - 1: f = False

                Exit For

            End If

        Next j

        If f Then a(i) = x

    Loop Until i = 15

    For i = 1 To 15

        s = s & a(i) & " "

    Next i

    Text1 = s

    Call sub1(a, b)

    s = ""

    For i = 1 To 15

        s = s & b(i) & " "

    Next i

    Text2 = s

End Sub

 

Private Sub sub1(a() As Integer, b() As String)

    b(1) = "+1"

    For i = 2 To UBound(a)

        If a(i) > a(i - 1) Then b(i) = "+1"

        If a(i) < a(i - 1) Then b(i) = "-1"

    Next i

End Sub

 

Private Sub Command2_Click()

    Text1 = ""

    Text2 = ""

End Sub

 

Private Sub Command3_Click()

End

End Sub

 

【题目 13 】下面程序的功能是，找出 2-100 以内的包含 3 个以上素数的连续 7 个自然数序列。

答：

源程序：

Private Sub Command1_Click()

    Dim i As Integer, j As Integer

    Dim k As Integer, s As String

    For i = 2 To 94

        k = 0

        s = ""

        For j = 0 To 6

            s = s & Str(i + j)

            If prime(i + j) Then k = k + 1

        Next j

        If k >= 3 Then

            Text1 = Text1 & s & "  (" & k & " 个素数 )" & vbCrLf

        End If

    Next i

End Sub

 

Function prime(n As Integer) As Boolean

   Static k As Integer

    k = k + 1

    If k = 1 Then k = k + 1

    If n Mod k <> 0 And k <= Sqr(n) Then

        prime = prime(n)

    ElseIf n Mod k <> 0 Or k = n Then

        prime = True

    End If

    k = 0

End Function

 

【题目 14 】一个正整数被称为奇妙平方数，如果此数的平方与它的逆序数的平方互为逆序数。例如， 12^2=144, 21^2=441,12 与 21 互逆 ,144 与 441 互逆 ,12 就是奇妙平方数 . 找出 1-300 以内所有的奇妙平方数。

答：

源程序：

Option Base 1

Dim a() As Long

Private Sub Command1_Click()

    Dim i As Long, x As Long

    ReDim a(1)

    For i = 1 To 300

        If fun2(i) Then

            For j = 1 To UBound(a)

                If a(j) = fun(i) Then Exit For

            Next j

            If j > UBound(a) Then

                k = k + 1

                ReDim Preserve a(k)

                a(k) = i

            End If

        End If

    Next i

    For i = 1 To UBound(a)

        List1.AddItem a(i) & "^2=" & a(i) ^ 2

        List2.AddItem fun(a(i)) & "^2=" & fun(a(i)) ^ 2

    Next i

End Sub

 

Private Function fun(i As Long) As Long

    Dim st As String, s As Integer

    s = Len(CStr(i))

    For j = 1 To s

        st = Mid(CStr(i), j, 1) & st

    Next j

    fun = Val(st)

End Function

Private Function fun2(i As Long) As Boolean

    x = fun(i)

    If x <> i And i ^ 2 = fun(x ^ 2) And fun(i ^ 2) = x ^ 2 Then

        fun2 = True

    End If

End Function

 

Private Sub Command2_Click()

List1.Clear

List2.Clear

End Sub

 

Private Sub Command3_Click()

End

End Sub