自编程序得到的一组大素数

ysr

如下慢速程序比前一个快速还稍快一点啊？代码如下：

Private Function fenjieyinzi(sa As String) As String
'判断素数及分解合数的程序（小数值的）
Dim X, A, B, k As String
A = Val(sa)

X = 3
If A <= 1 Or A > Int(A) Then
If A = 1 Then
fenjieyinzi = "它既不是质数，也不是合数"

Else
MsgBox "error"
End If
  
Else

Do While A / 2 = Int(A / 2) And A >= 4
  
If B = 0 Then
fenjieyinzi = fenjieyinzi & "2"
B = 1
Else
fenjieyinzi = fenjieyinzi & "*2"
End If
A = A / 2
k = A
  
Loop

Do While A > 1
Do While X <= Sqr(A)
Do While A / X = Int(A / X) And A >= X * X
  
If B = 0 Then
fenjieyinzi = fenjieyinzi & X
B = 1
Else
fenjieyinzi = fenjieyinzi & "*" & X
End If
A = A / X
Loop
  
X = X + 2
Loop
  
k = A
A = 1
Loop
  
If B = 1 Then
fenjieyinzi = fenjieyinzi & "*" & k
Else
fenjieyinzi = "这是一个质数"
End If

End If

End Function

Private Function fenjieyinzi0(sa As String) As String
Dim A, n
n = Trim(sa)
If Len(n) < 10 Then
fenjieyinzi0 = fenjieyinzi(Trim(n))
Else
n1 = MPC(Trim(n), 1)
A = 123
'a为明文
a1 = zzxc(Trim(n), Trim(A))
If Val(a1) > 1 Then
fenjieyinzi0 = a1 & "*"
Else
c = 999
'c为公约
Do While zzxc(Trim(n1), Trim(c)) > 1
c = Val(c - 1)
Loop
d = qniyuan(Trim(c), Trim(n1))
'd为逆元为私钥
a2 = qksmimo(Trim(A), Trim(c), Trim(n))
'a2为密文
a3 = qksmimo(Trim(a2), Trim(d), Trim(n))
If MBJC(Trim(a3), Trim(A)) = 0 Then
fenjieyinzi0 = "这是素数有"
Else
fenjieyinzi0 = "2*2"
End If
End If
End If


End Function
Public Function MCC1(D1 As String, D2 As String) As String ';大整数的除法
'可能还有优化和提高速度的空间

Dim ss
ss = MBJC(D1, D2)
If ss = -1 Then
MCC1 = "0" & "/" & D1
  Else
  If ss = 0 Then
   MCC1 = 1
   Else
   If Len(D1) = Len(D2) Then
Do While MBJC(D1, D2) >= 0
S1 = S1 + 1
D1 = MPC(D1, D2)
Loop
If D1 = 0 Then
MCC1 = S1
Else
    MCC1 = S1 & "/" & D1
End If
    Else
    If Len(D2) < 9 Then
     MCC1 = MCC(D1, D2)
     Else
    Dim X, Y ';定义分段长度
   
    X = Len(D1) \ 4: Y = Len(D2) \ 4
    If Len(D1) > 4 * X Then
    X = X + 1
    D1 = String(4 * X - Len(D1), "0") & D1
    ElseIf Len(D2) > 4 * Y Then
    Y = Y + 1
    D2 = String(4 * Y - Len(D2), "0") & D2
    Else
    D1 = String(4 * X - Len(D1), "0") & D1
    D2 = String(4 * Y - Len(D2), "0") & D2
    End If
  X = Len(D1) \ 4: Y = Len(D2) \ 4
Dim JW, jcc, jss, jcs

  Dim A() As String, B() As String
  
  ReDim A(1 To X)
  ReDim B(1 To Y)
  For i = 1 To X
  A(i) = Mid(D1, i * 4 - 3, 4)
  Next
  For j = 1 To Y
  B(j) = Mid(D2, j * 4 - 3, 4)
  jws = jws & A(j)
  Next
If Len(qqdl(Trim(jws))) <= Len(qqdl(D2)) Then
  jcc = Val(Left(qqdl(A(1) & A(2)), 2)) \ Val(Left(qqdl(B(1) & B(2)), 2))
  Else
  jcc = Val(Left(qqdl(A(1) & A(2)), 2 + Len(qqdl(Trim(jws))) - Len(qqdl(D2)))) \ Val(Left(qqdl(B(1) & B(2)), 2))
  End If

  jss = MbC(Trim(jcc), D2)
  
   
      Do While MBJC(Trim(jws), Trim(jss)) = -1
      jcc = jcc - 1
      jss = MbC(Trim(jcc), D2)
      Loop
  JW = MPC(Trim(jws), Trim(jss))
  
    z = X - Y
   
    Dim c() As String
    ReDim c(1 To z)
    For s = 1 To z
     If MBJC(JW & A(s + Y), D2) = -1 Then
       c(s) = "0000"
       Else
       If Len(qqdl(JW & A(s + Y))) = Len(qqdl(D2)) Then
  jwc = Val(Left(qqdl(JW & A(s + Y)), 4)) \ Val(Left(qqdl(B(1) & B(2)), 4))
  Else
  If Len(qqdl(JW & A(s + Y))) <= Len(qqdl(D2)) Then
  jwc = Val(Left(qqdl(JW & A(s + Y)), 4)) \ Val(Left(qqdl(B(1) & B(2)), 4))
  Else
  jwc = Val(Left(qqdl(JW & A(s + Y)), 4 + Len(qqdl(JW & A(s + Y))) - Len(qqdl(D2)))) / Val(Left(qqdl(B(1) & B(2)), 4))
  jwc = Format(Val(jwc), "0.000000")
  If InStr(jwc, ".") = 0 Then
  jwc = jwc
  Else
  jwc = Left(jwc, InStr(jwc, ".") - 1)
  End If
  End If
  End If
     c(s) = jwc
         End If
       jsw = MbC(Trim(c(s)), Trim(D2))
       Do While MBJC(JW & A(s + Y), Trim(jsw)) = -1
      c(s) = c(s) - 1
      jsw = MbC(Trim(c(s)), D2)
      Loop
     JW = MPC(JW & A(s + Y), MbC(Val(c(s)), D2))
     Do While MBJC(Trim(JW), Trim(D2)) >= 0
     jwc1 = jwc1 + 1
     JW = MPC(Trim(JW), Trim(D2))
     Loop
     c(s) = Val(c(s) + jwc1)
    c(s) = Right(100000000 + Val(c(s)), 4)
     
    jcc = jcc & c(s)
    Next s
    If JW = 0 Then
    MCC1 = jcc
    Else
    MCC1 = jcc & "/" & JW
    End If
   
  For i = 1 To Len(MCC1)
    If Not Mid(MCC1, i, 1) = "0" Then
        Exit For
    End If
Next
strTmp = Mid(MCC1, i)
  If Len(strTmp) = 0 Then
  MCC1 = "0"
  Else
MCC1 = strTmp
End If
   
    End If
   
  End If
End If
End If
End Function

Private Function qniyuan(sa As String, sb As String) As String
Dim n, p, A, B, c, d, r
n = Trim(sa)
p = Trim(sb)

A = 1
B = 0
c = 0
d = 1
If Len(n) < 10 And Len(p) < 10 Then
If Val(n) > Val(p) Then
m = n
q = p
S1 = 1
Else
m = p
q = n
S1 = 0
End If
Do Until Val(m) Mod Val(q) = 0
s = m \ q
r = m Mod q
S1 = Val(S1 + 1)
If S1 Mod 2 = 1 Then
A = A
B = A * s + B
c = c
d = c * s + d
Else
B = B
A = A + B * s
d = d
c = c + d * s
End If
m = q
q = r
Loop
If Val(A + B * m) = p Then
B = B
A = A + B * (m - 1)
d = d
c = c + d * (m - 1)
Else
If Val(B + A * m) = p Then
A = A
B = B + A * m
c = c
d = d + c * m
Else
B = B
A = A + B * (m - 1)
d = d
c = c + d * (m - 1)
End If
End If

Else
If MBJC(Trim(n), Trim(p)) > 0 Then
m = n
q = p
S1 = 1
Else
m = p
q = n
S1 = 0
End If
Do Until zhengchuqyushu(MCC1(Trim(m), Trim(q))) = 0
s = zhengchuqy(MCC1(Trim(m), Trim(q)))
r = zhengchuqyushu(MCC1(Trim(m), Trim(q)))
S1 = Val(S1 + 1)
If S1 Mod 2 = 1 Then
A = A
B = MPC1(MbC(Trim(A), Trim(s)), Trim(B))
c = c
d = MPC1(MbC(Trim(c), Trim(s)), Trim(d))
Else
B = B
A = MPC1(Trim(A), MbC(Trim(B), Trim(s)))
d = d
c = MPC1(Trim(c), MbC(Trim(d), Trim(s)))
End If
m = q
q = r
Loop
If MBJC(MPC1(Trim(A), MbC(Trim(B), Trim(m))), Trim(p)) = 0 Then
B = B
A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
d = d
c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
Else
If MBJC(MPC1(Trim(B), MbC(Trim(A), Trim(m))), Trim(p)) = 0 Then
A = A
B = MPC1(Trim(B), MbC(Trim(A), Trim(m)))
c = c
d = MPC1(Trim(d), MbC(Trim(c), Trim(m)))
Else
B = B
A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
d = d
c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
End If
End If

End If
qniyuan = A

End Function

Private Function zzxc(sa As String, sb As String) As String
'辗转相除输出最大公约数
Dim A, B, c, d, r
  A = Trim(sa)
  B = Trim(sb)
If Len(A) < 10 And Len(B) < 10 Then

If Val(A) > Val(B) Then
c = A
d = B
Else
c = B
d = A
End If
Do Until Val(c) Mod Val(d) = 0
r = c Mod d
c = d
d = r
Loop
Else
If MBJC(Trim(A), Trim(B)) >= 1 Then
c = A
d = B
Else
c = B
d = A
End If
Do Until zhengchuqyushu(MCC1(Trim(c), Trim(d))) = 0
r = zhengchuqyushu(MCC1(Trim(c), Trim(d)))
c = d
d = r
Loop
End If
zzxc = d
End Function

Private Function qksmimo(sa As String, sb As String, sc As String) As String
'求快速幂模的程序
Dim c, e, n, d
c = Trim(sa)
e = Trim(sb)
n = Trim(sc)
d = 1
If Len(c) < 5 And Len(e) < 5 And Len(n) < 5 Then
c = Val(c): n = Val(n)
Do While e > 0
If Right(e, 1) Mod 2 = 0 Then
c = c * c Mod n
e = e / 2
Else
d = d * c Mod n
e = e - 1
End If
Loop
Else
c = c
Do While MBJC(Trim(e), 1) >= 0
If Right(e, 1) Mod 2 = 0 Then
c = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(c)), Trim(n)))
e = zhengchuqy(MCC1(Trim(e), 2))
Else
d = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(d)), Trim(n)))
e = MPC(Trim(e), 1)
End If
Loop
End If

qksmimo = d
End Function


Private Function zhengchuqyushu(sa As String) As String
'提取余数的程序
If InStr(sa, "/") = 0 Then
zhengchuqyushu = 0
Else
zhengchuqyushu = Mid(sa, InStr(sa, "/") + 1)
End If


End Function

Private Function zhengchuqy(sa As String) As String
'取整除后的商或方根或立方跟的整数部分的程序
If InStr(sa, "/") = 0 Then
zhengchuqy = sa
Else
zhengchuqy = Left(sa, InStr(sa, "/") - 1)
End If


End Function

Public Function MBBC(D1 As String) As String 'kai pingfang
'开平方的程序
If Len(D1) < 10 Then
jss = Int(Sqr(Val(D1)))
JW = Val(D1) - (jss) ^ 2
If JW = 0 Then
MBBC = jss
Else
MBBC = jss & "/" & JW
   End If
Else
Dim X 'shuju changdu
X = Len(D1) \ 4
D2 = String(4 - Len(D1) + 4 * X, "0") & D1
Dim A() As String
ReDim A(4 To 4 * X + 4)
Dim B() As String
ReDim B(2 To 2 * X)
Dim i, j, js
For i = 4 To 4 * X + 4 Step 4

A(i) = Mid(D2, i - 3, 4)
js = Int(Sqr(Val(A(4) & A(8))))
JW = Val(A(4) & A(8)) - (js) ^ 2
Next
  j = 4
  Do While j <= 2 * X
  
  jws = MPC1(JW & "0000", A(2 * j + 4))
  If MBJC(Trim(jws), MbC(Trim(js), 200)) <= 0 Then
   B(j) = "00"
   Else
   jwc = Left(jws, Len(jws) - Len(MbC(Trim(js), 200)) + 2) \ Left(MbC(Trim(js), 200), 2)
   If Len(jwc) > 2 Then
    B(j) = 99
    Else
    B(j) = jwc
    End If
  
   
    Do While MBJC(Trim(jws), MbC(MPC1(B(j), MbC(Trim(js), 200)), B(j))) = -1
   
    B(j) = B(j) - 1
   
              Loop
         End If
         JW = MPC(Trim(jws), MbC(MPC1(MbC(200, Trim(js)), B(j)), B(j)))
      
    js = MPC1(MbC(Trim(js), 100), Trim(B(j)))
   
      
  j = j + 2
  If JW = 0 Then
      
  MBBC = js
  Else
  MBBC = js & "/" & JW
  End If
  Loop
  
End If
End Function
Public Function MBJC(D1 As String, D2 As String) As String 'bijiao
'比较大小的程序
If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) And Len(D1) >= 10 Then


Dim X, Y
X = Len(D1) \ 4: Y = Len(D2) \ 4
Dim A() As String, B() As String
ReDim A(4 To 4 * X + 4)
ReDim B(4 To 4 * Y + 4)
If Val(Left(D1, Len(D1) - 4 * X)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = 1
Else
If Val(Left(D1, Len(D1) - 4 * X)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = -1
Else
For i = 4 To 4 * X Step 4
A(i) = Mid(D1, Len(D1) - i + 1, 4)
B(i) = Mid(D2, Len(D2) - i + 1, 4)
Next
j = 4 * X
Do While A(j) = B(j) And j >= 8

j = j - 4
    Loop
   
   
  If Val(A(j)) - Val(B(j)) > 0 Then
  MBJC = 1
  Else
  If Val(A(j)) - Val(B(j)) < 0 Then
  MBJC = -1
  Else
  MBJC = 0
  End If
  
End If




End If
End If
End If
If Len(D1) < 10 Then
ja = Val(D1) - Val(D2)
  If ja > 0 Then
   MBJC = 1
   Else
    If ja = 0 Then
     MBJC = 0
    Else
   
  MBJC = -1
End If
End If
End If

End If
End If
End Function

Public Function MbC(D1 As String, D2 As String) As String
'乘法可调用程序
Dim j1&, j2&, e&, d&, e1&, m, n

   ' 按列法计算C=A*B
m = Trim(D1): n = Trim(D2)
X = Len(m) \ 4: Y = Len(n) \ 4
m = String(4 * X + 4 - Len(m), "0") & m
n = String(4 * Y + 4 - Len(n), "0") & n
X = X + 1: Y = Y + 1
Dim A(), B()
ReDim A(1 To X): ReDim B(1 To Y)
For i1 = 1 To X
A(i1) = Val(Mid(m, i1 * 4 - 3, 4))
Next
For i2 = 1 To Y
B(i2) = Val(Mid(n, i2 * 4 - 3, 4))
Next
ma = X: mb = Y
    MC = ma + mb
    ReDim c(MC)
    e1 = 0
    j1 = ma: j2 = ma
    For i = MC To 2 Step -1
        If i <= ma Then j2 = i - 1
        e = e1: e1 = 0
        For j = j1 To j2
            e = e + A(j) * B(i - j)
            If e > 2040000000 Then '减少进位次数
                e = e - 2040000000
                e1 = e1 + 204000
            End If
        Next j

        If j1 > 1 Then j1 = j1 - 1
base = 10000
        d = e \ base
        c(i) = e - d * base
        If Len(c(i)) < 4 Then
        c(i) = String(4 - Len(c(i)), "0") & c(i)
        Else
        c(i) = c(i)
        End If
jc = c(i) & jc
        e1 = e1 + d
    Next i
    jc = d & jc
   MbC = qqdl(Trim(jc))
End Function

Private Function qqdl(sa As String) As String
'去前导0的程序
  
  For i = 1 To Len(sa)
    If Not Mid(sa, i, 1) = "0" Then
        Exit For
    End If
Next
strTmp = Mid(sa, i)
  If Len(strTmp) = 0 Then
  qqdl = "0"
  Else
qqdl = strTmp
End If
End Function
Public Function MPC(D1 As String, D2 As String) As String 'jianfaqi
'减法可调用程序
Dim X, Y '两数长度
If Len(D1) >= Len(D2) Then
D4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
D4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
X = Len(d3): Y = Len(D4)
Dim A() As Integer, B1() As Integer, C1() As Integer, e1() As Integer
ReDim A(1 To X)
ReDim B1(1 To Y)
ReDim C1(1 To X)
ReDim e1(1 To X)
Dim i, j, c2, CJ, JW
For j = Y To 1 Step -1 'D2
JW = 1 'yu jie weichuzhi
B1(j) = Mid$(D4, j, 1) '每位数
For i = X To 1 Step -1  'D1
  A(i) = Mid$(d3, i, 1) '每位数
  C1(i) = 10 + A(i) - B1(i) - 1 + JW '计算jia
  JW = C1(i) \ 10
  e1(i) = C1(i) Mod 10
Next
Next
For r = 1 To X
MPC = MPC & e1(r)
For i = 1 To Len(MPC)
   If Not Mid(MPC, i, 1) = "0" Then
       Exit For
   End If
Next
strTmp = Mid(MPC, i)
If Len(strTmp) = 0 Then
MPC = "0"
Else
MPC = strTmp
End If
Next


End Function

Public Function DeleteSpace(Tmp As String) As String
'去掉空格的程序
   Dim Inst As Integer
   Do
       Tmp = Replace(Tmp, " ", "")
       DoEvents
       Inst = InStr(Tmp, " ")
   Loop While Inst > 0
   DeleteSpace = Tmp
End Function








Public Function MCC(D1 As String, D2 As String) As String '除数少于8位的除法
'除法可调用程序除数少于8位的
If Len(D1) < Len(D2) Then
MCC = "0" & "/" & D1
Else
If Len(D1) < 9 Then
  ja = Val(D1) \ Val(D2)
  If Val(D1) - (Val(D1) \ Val(D2)) * Val(D2) = 0 Then
  
  MCC = ja
  Else
  
  MCC = ja & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
  End If
  Else
  
Dim X 'fen duan changdu
X = Len(D1)
  
   
  
   Dim A() As String
    ReDim A(1 To X)  '定义数组的储存空间
    For i = 1 To X Step 1  '把被除数各位放在a()中
     A(i) = Mid(D1, i, 1)
      
     
     Next i
    Dim B() As String
    JW = 0
   ReDim B(1 To X)
   For j = 1 To X Step 1
  B(j) = Val(JW & A(j)) \ Val(D2)
    JW = Val(JW & A(j)) - Val(B(j)) * Val(D2)
     Next j
     For r = 1 To X
     If JW = 0 Then
        MCC = MCC & B(r)
        Else
        CJ = CJ & B(r)
        MCC = CJ & "/" & JW
     
  End If
  
  For i = 1 To Len(MCC)
If Not Mid(MCC, i, 1) = "0" Then
     Exit For
End If
Next
strTmp = Mid(MCC, i)
If Len(strTmp) = 0 Then
MCC = "0"
Else
MCC = strTmp
End If
  
Next

End If
   
   End If

   

End Function
Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
'加法可调用程序
Dim X, Y '两数长度
If Len(D1) >= Len(D2) Then
D4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
D4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
X = Len(d3): Y = Len(D4)
Dim A() As Integer, B1() As Integer, C1() As Integer, e1() As Integer
ReDim A(1 To X)
ReDim B1(1 To Y)
ReDim C1(1 To X)
ReDim e1(1 To X)
Dim i, j, c2, CJ, JW
For j = Y To 1 Step -1 'D2
JW = 0 '进位清0
B1(j) = Mid$(D4, j, 1) '每位数
For i = X To 1 Step -1  'D1
  A(i) = Mid$(d3, i, 1) '每位数
  C1(i) = A(i) + B1(i) + JW '计算jia
  JW = C1(i) \ 10
  e1(i) = C1(i) Mod 10
Next
Next
For r = 1 To X
If JW = 0 Then
MPC1 = MPC1 & e1(r)
Else
jc = jc & e1(r)
MPC1 = JW & jc
End If
Next

End Function


Private Sub Command1_Click()
Dim X, m
t = Timer
X = Trim(Text1)
m = fenjieyinzi0(Trim(X))
s = Len(X)

If InStr(m, "*") = 0 Then
Text2 = "这是素数， 有" & s & "位，用时 " & Timer - t & "秒"
Else
Text2 = "这是合数*， 有" & s & "位，用时 " & Timer - t & "秒"
End If

End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""

End Sub

ysr

明白了，主楼的数据是在单位电脑（台式机）上算的，比我的笔记本电脑（双核笔记本，是旧型号，现在的型号至少6核，有高达20核了）快多少倍，而且我的方法是串行程序，不是分布程序，不能用多台电脑并行的运算，辗转相除法本身程序少但是循环程序，前一个循环结果是下一个循环的输入值，无法并行运算，所以，时间稍长一些，尤其是电脑配置低的时候。
改进一下，也许有提升空间，AI提示可以把小因子试除筛掉一部分，对含有小因子的合数速度就快了，其他不含有小因子的合数，速度并不快，但也延迟不了多少时间，总之还是可行的办法。
我可以改进一下试试。

ysr

5*7*11*13*17*19*23*29*31*37*43*47=2499551961741835，这些小因子可以通过辗转相除法一次性排除。

ysr

2499551961741835*53=132476253972317255
132476253972317255*59=7816098984366718045
7816098984366718045*61=476782038046369800745
476782038046369800745*67=31944396549106776649915
就这些吧

ysr

慢速程序结果：
170141183460469231731687303715884107729  这是合数*， 有39位，用时 7.316406秒
170141183460469231731687303715884105757  这是素数， 有39位，用时 7.152344秒

ysr

慢速程序的代码（主要是快速程序中的快速除法有问题遇到某些整数会出现下标越界的情况）：

Private Function fenjieyinzi(sa As String) As String
'判断素数及分解合数的程序（小数值的）
Dim X, A, B, k As String
A = Val(sa)

X = 3
If A <= 1 Or A > Int(A) Then
If A = 1 Then
fenjieyinzi = "它既不是质数，也不是合数"

Else
MsgBox "error"
End If
  
Else

Do While A / 2 = Int(A / 2) And A >= 4
  
If B = 0 Then
fenjieyinzi = fenjieyinzi & "2"
B = 1
Else
fenjieyinzi = fenjieyinzi & "*2"
End If
A = A / 2
k = A
  
Loop

Do While A > 1
Do While X <= Sqr(A)
Do While A / X = Int(A / X) And A >= X * X
  
If B = 0 Then
fenjieyinzi = fenjieyinzi & X
B = 1
Else
fenjieyinzi = fenjieyinzi & "*" & X
End If
A = A / X
Loop
  
X = X + 2
Loop
  
k = A
A = 1
Loop
  
If B = 1 Then
fenjieyinzi = fenjieyinzi & "*" & k
Else
fenjieyinzi = "这是一个质数"
End If

End If

End Function

Private Function fenjieyinzi0(sa As String) As String
Dim A, n, sb
n = Trim(sa)
If Len(n) < 10 Then
fenjieyinzi0 = fenjieyinzi(Trim(n))
Else
n1 = MPC(Trim(n), 1)
A = 123
'a为明文
sb = "31944396549106776649915"
a1 = zzxc(Trim(n), Trim(A))
sb1 = zzxc(Trim(n), Trim(sb))
If Val(a1) > 1 Then
fenjieyinzi0 = a1 & "*"
Else
If Val(sb1) > 1 Then
fenjieyinzi0 = "5*"
Else
c = 999
'c为公约

Do While zzxc(Trim(n1), Trim(c)) > 1
c = Val(c - 1)
Loop
d = qniyuan(Trim(c), Trim(n1))
'd为逆元为私钥
a2 = qksmimo(Trim(A), Trim(c), Trim(n))
'a2为密文
a3 = qksmimo(Trim(a2), Trim(d), Trim(n))
If MBJC(Trim(a3), Trim(A)) = 0 Then
fenjieyinzi0 = "这是素数有"
Else
fenjieyinzi0 = "2*2"
End If
End If
End If
End If

End Function
Public Function MCC1(D1 As String, D2 As String) As String '大整数的除法
'除法可调用程序

Dim ss
ss = MBJC(D1, D2)
If ss = -1 Then
MCC1 = "0" & "/" & D1
Else
If ss = 0 Then
MCC1 = 1
Else
If Len(D1) = Len(D2) Then
s = Val(Left(D1, 1)) \ Val(Left(D2, 1))

Do While MBJC(MbC(Trim(s), Trim(D2)), D1) = 1
  s = s - 1
  Loop
  If MBJC(MbC(Trim(s), Trim(D2)), D1) = 0 Then
   MCC1 = s
   Else
   MCC1 = s & "/" & MPC(Trim(D1), MbC(Trim(s), Trim(D2)))

End If
  
  Else
  If Len(D2) < 9 Then
   MCC1 = MCC(D1, D2)
   Else
  Dim X, Y '定义分段长度
  X = Len(D1): Y = Len(D2)
  
Dim JW, jcc, jss, jcs
Dim A() As String, B() As String

ReDim A(1 To X)
ReDim B(1 To Y)
For i = 1 To X
A(i) = Mid(D1, i, 1)
Next
For j = 1 To Y
B(j) = Mid(D2, j, 1)
Next
jcc = Val(A(1) & A(2)) \ Val(B(1) & B(2))
  
     
      
jss = MbC(Trim(jcc), D2)
For i1 = 1 To Y
  jws = jws & A(i1)
    Next
JW = MPC(Trim(jws), Trim(jss))

  z = X - Y
  
  Dim c() As String
  ReDim c(1 To z)
  For s = 1 To z
   If MBJC(JW & A(s + Y), D2) = -1 Then
     c(s) = "0"
     Else
   jwc = Val(Left(JW & A(s + Y), 3)) \ Val(Left(D2, 2))
    If Len(jwc) > 1 Then
    c(s) = "9"
     Else
      c(s) = jwc
       End If
   
   Do While MBJC(JW & A(s + Y), MbC(Val(c(s)), D2)) = -1
  c(s) = Right(10000 + Val(c(s) - 1), 1)
   Loop
   End If

   JW = MPC(JW & A(s + Y), MbC(Val(c(s)), D2))
   
  jcc = jcc & c(s)
  Next s
  If JW = 0 Then
  MCC1 = jcc
  Else
  MCC1 = jcc & "/" & JW
  End If
  
For i = 1 To Len(MCC1)
  If Not Mid(MCC1, i, 1) = "0" Then
      Exit For
  End If
Next
strTmp = Mid(MCC1, i)
If Len(strTmp) = 0 Then
MCC1 = "0"
Else
MCC1 = strTmp
End If
  
  
  
  End If
  
  
  
  
  
End If
End If
End If
End Function


Private Function qniyuan(sa As String, sb As String) As String
Dim n, p, A, B, c, d, r
n = Trim(sa)
p = Trim(sb)

A = 1
B = 0
c = 0
d = 1
If Len(n) < 10 And Len(p) < 10 Then
If Val(n) > Val(p) Then
m = n
q = p
S1 = 1
Else
m = p
q = n
S1 = 0
End If
Do Until Val(m) Mod Val(q) = 0
s = m \ q
r = m Mod q
S1 = Val(S1 + 1)
If S1 Mod 2 = 1 Then
A = A
B = A * s + B
c = c
d = c * s + d
Else
B = B
A = A + B * s
d = d
c = c + d * s
End If
m = q
q = r
Loop
If Val(A + B * m) = p Then
B = B
A = A + B * (m - 1)
d = d
c = c + d * (m - 1)
Else
If Val(B + A * m) = p Then
A = A
B = B + A * m
c = c
d = d + c * m
Else
B = B
A = A + B * (m - 1)
d = d
c = c + d * (m - 1)
End If
End If

Else
If MBJC(Trim(n), Trim(p)) > 0 Then
m = n
q = p
S1 = 1
Else
m = p
q = n
S1 = 0
End If
Do Until zhengchuqyushu(MCC1(Trim(m), Trim(q))) = 0
s = zhengchuqy(MCC1(Trim(m), Trim(q)))
r = zhengchuqyushu(MCC1(Trim(m), Trim(q)))
S1 = Val(S1 + 1)
If S1 Mod 2 = 1 Then
A = A
B = MPC1(MbC(Trim(A), Trim(s)), Trim(B))
c = c
d = MPC1(MbC(Trim(c), Trim(s)), Trim(d))
Else
B = B
A = MPC1(Trim(A), MbC(Trim(B), Trim(s)))
d = d
c = MPC1(Trim(c), MbC(Trim(d), Trim(s)))
End If
m = q
q = r
Loop
If MBJC(MPC1(Trim(A), MbC(Trim(B), Trim(m))), Trim(p)) = 0 Then
B = B
A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
d = d
c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
Else
If MBJC(MPC1(Trim(B), MbC(Trim(A), Trim(m))), Trim(p)) = 0 Then
A = A
B = MPC1(Trim(B), MbC(Trim(A), Trim(m)))
c = c
d = MPC1(Trim(d), MbC(Trim(c), Trim(m)))
Else
B = B
A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
d = d
c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
End If
End If

End If
qniyuan = A

End Function

Private Function zzxc(sa As String, sb As String) As String
'辗转相除输出最大公约数
Dim A, B, c, d, r
  A = Trim(sa)
  B = Trim(sb)
If Len(A) < 10 And Len(B) < 10 Then

If Val(A) > Val(B) Then
c = A
d = B
Else
c = B
d = A
End If
Do Until Val(c) Mod Val(d) = 0
r = c Mod d
c = d
d = r
Loop
Else
If MBJC(Trim(A), Trim(B)) >= 1 Then
c = A
d = B
Else
c = B
d = A
End If
Do Until zhengchuqyushu(MCC1(Trim(c), Trim(d))) = 0
r = zhengchuqyushu(MCC1(Trim(c), Trim(d)))
c = d
d = r
Loop
End If
zzxc = d
End Function

Private Function qksmimo(sa As String, sb As String, sc As String) As String
'求快速幂模的程序
Dim c, e, n, d
c = Trim(sa)
e = Trim(sb)
n = Trim(sc)
d = 1
If Len(c) < 5 And Len(e) < 5 And Len(n) < 5 Then
c = Val(c): n = Val(n)
Do While e > 0
If Right(e, 1) Mod 2 = 0 Then
c = c * c Mod n
e = e / 2
Else
d = d * c Mod n
e = e - 1
End If
Loop
Else
c = c
Do While MBJC(Trim(e), 1) >= 0
If Right(e, 1) Mod 2 = 0 Then
c = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(c)), Trim(n)))
e = zhengchuqy(MCC1(Trim(e), 2))
Else
d = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(d)), Trim(n)))
e = MPC(Trim(e), 1)
End If
Loop
End If

qksmimo = d
End Function


Private Function zhengchuqyushu(sa As String) As String
'提取余数的程序
If InStr(sa, "/") = 0 Then
zhengchuqyushu = 0
Else
zhengchuqyushu = Mid(sa, InStr(sa, "/") + 1)
End If


End Function

Private Function zhengchuqy(sa As String) As String
'取整除后的商或方根或立方跟的整数部分的程序
If InStr(sa, "/") = 0 Then
zhengchuqy = sa
Else
zhengchuqy = Left(sa, InStr(sa, "/") - 1)
End If


End Function

Public Function MBBC(D1 As String) As String 'kai pingfang
'开平方的程序
If Len(D1) < 10 Then
jss = Int(Sqr(Val(D1)))
JW = Val(D1) - (jss) ^ 2
If JW = 0 Then
MBBC = jss
Else
MBBC = jss & "/" & JW
   End If
Else
Dim X 'shuju changdu
X = Len(D1) \ 4
D2 = String(4 - Len(D1) + 4 * X, "0") & D1
Dim A() As String
ReDim A(4 To 4 * X + 4)
Dim B() As String
ReDim B(2 To 2 * X)
Dim i, j, js
For i = 4 To 4 * X + 4 Step 4

A(i) = Mid(D2, i - 3, 4)
js = Int(Sqr(Val(A(4) & A(8))))
JW = Val(A(4) & A(8)) - (js) ^ 2
Next
  j = 4
  Do While j <= 2 * X
  
  jws = MPC1(JW & "0000", A(2 * j + 4))
  If MBJC(Trim(jws), MbC(Trim(js), 200)) <= 0 Then
   B(j) = "00"
   Else
   jwc = Left(jws, Len(jws) - Len(MbC(Trim(js), 200)) + 2) \ Left(MbC(Trim(js), 200), 2)
   If Len(jwc) > 2 Then
    B(j) = 99
    Else
    B(j) = jwc
    End If
  
   
    Do While MBJC(Trim(jws), MbC(MPC1(B(j), MbC(Trim(js), 200)), B(j))) = -1
   
    B(j) = B(j) - 1
   
              Loop
         End If
         JW = MPC(Trim(jws), MbC(MPC1(MbC(200, Trim(js)), B(j)), B(j)))
      
    js = MPC1(MbC(Trim(js), 100), Trim(B(j)))
   
      
  j = j + 2
  If JW = 0 Then
      
  MBBC = js
  Else
  MBBC = js & "/" & JW
  End If
  Loop
  
End If
End Function
Public Function MBJC(D1 As String, D2 As String) As String 'bijiao
'比较大小的程序
If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) And Len(D1) >= 10 Then


Dim X, Y
X = Len(D1) \ 4: Y = Len(D2) \ 4
Dim A() As String, B() As String
ReDim A(4 To 4 * X + 4)
ReDim B(4 To 4 * Y + 4)
If Val(Left(D1, Len(D1) - 4 * X)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = 1
Else
If Val(Left(D1, Len(D1) - 4 * X)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = -1
Else
For i = 4 To 4 * X Step 4
A(i) = Mid(D1, Len(D1) - i + 1, 4)
B(i) = Mid(D2, Len(D2) - i + 1, 4)
Next
j = 4 * X
Do While A(j) = B(j) And j >= 8

j = j - 4
    Loop
   
   
  If Val(A(j)) - Val(B(j)) > 0 Then
  MBJC = 1
  Else
  If Val(A(j)) - Val(B(j)) < 0 Then
  MBJC = -1
  Else
  MBJC = 0
  End If
  
End If




End If
End If
End If
If Len(D1) < 10 Then
ja = Val(D1) - Val(D2)
  If ja > 0 Then
   MBJC = 1
   Else
    If ja = 0 Then
     MBJC = 0
    Else
   
  MBJC = -1
End If
End If
End If

End If
End If
End Function

Public Function MbC(D1 As String, D2 As String) As String
'乘法可调用程序
Dim j1&, j2&, e&, d&, e1&, m, n

   ' 按列法计算C=A*B
m = Trim(D1): n = Trim(D2)
X = Len(m) \ 4: Y = Len(n) \ 4
m = String(4 * X + 4 - Len(m), "0") & m
n = String(4 * Y + 4 - Len(n), "0") & n
X = X + 1: Y = Y + 1
Dim A(), B()
ReDim A(1 To X): ReDim B(1 To Y)
For i1 = 1 To X
A(i1) = Val(Mid(m, i1 * 4 - 3, 4))
Next
For i2 = 1 To Y
B(i2) = Val(Mid(n, i2 * 4 - 3, 4))
Next
ma = X: mb = Y
    MC = ma + mb
    ReDim c(MC)
    e1 = 0
    j1 = ma: j2 = ma
    For i = MC To 2 Step -1
        If i <= ma Then j2 = i - 1
        e = e1: e1 = 0
        For j = j1 To j2
            e = e + A(j) * B(i - j)
            If e > 2040000000 Then '减少进位次数
                e = e - 2040000000
                e1 = e1 + 204000
            End If
        Next j

        If j1 > 1 Then j1 = j1 - 1
base = 10000
        d = e \ base
        c(i) = e - d * base
        If Len(c(i)) < 4 Then
        c(i) = String(4 - Len(c(i)), "0") & c(i)
        Else
        c(i) = c(i)
        End If
jc = c(i) & jc
        e1 = e1 + d
    Next i
    jc = d & jc
   MbC = qqdl(Trim(jc))
End Function

Private Function qqdl(sa As String) As String
'去前导0的程序
  
  For i = 1 To Len(sa)
    If Not Mid(sa, i, 1) = "0" Then
        Exit For
    End If
Next
strTmp = Mid(sa, i)
  If Len(strTmp) = 0 Then
  qqdl = "0"
  Else
qqdl = strTmp
End If
End Function
Public Function MPC(D1 As String, D2 As String) As String 'jianfaqi
'减法可调用程序
Dim X, Y '两数长度
If Len(D1) >= Len(D2) Then
D4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
D4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
X = Len(d3): Y = Len(D4)
Dim A() As Integer, B1() As Integer, C1() As Integer, e1() As Integer
ReDim A(1 To X)
ReDim B1(1 To Y)
ReDim C1(1 To X)
ReDim e1(1 To X)
Dim i, j, c2, CJ, JW
For j = Y To 1 Step -1 'D2
JW = 1 'yu jie weichuzhi
B1(j) = Mid$(D4, j, 1) '每位数
For i = X To 1 Step -1  'D1
  A(i) = Mid$(d3, i, 1) '每位数
  C1(i) = 10 + A(i) - B1(i) - 1 + JW '计算jia
  JW = C1(i) \ 10
  e1(i) = C1(i) Mod 10
Next
Next
For r = 1 To X
MPC = MPC & e1(r)
For i = 1 To Len(MPC)
   If Not Mid(MPC, i, 1) = "0" Then
       Exit For
   End If
Next
strTmp = Mid(MPC, i)
If Len(strTmp) = 0 Then
MPC = "0"
Else
MPC = strTmp
End If
Next


End Function

Public Function DeleteSpace(Tmp As String) As String
'去掉空格的程序
   Dim Inst As Integer
   Do
       Tmp = Replace(Tmp, " ", "")
       DoEvents
       Inst = InStr(Tmp, " ")
   Loop While Inst > 0
   DeleteSpace = Tmp
End Function








Public Function MCC(D1 As String, D2 As String) As String '除数少于8位的除法
'除法可调用程序除数少于8位的
If Len(D1) < Len(D2) Then
MCC = "0" & "/" & D1
Else
If Len(D1) < 9 Then
  ja = Val(D1) \ Val(D2)
  If Val(D1) - (Val(D1) \ Val(D2)) * Val(D2) = 0 Then
  
  MCC = ja
  Else
  
  MCC = ja & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
  End If
  Else
  
Dim X 'fen duan changdu
X = Len(D1)
  
   
  
   Dim A() As String
    ReDim A(1 To X)  '定义数组的储存空间
    For i = 1 To X Step 1  '把被除数各位放在a()中
     A(i) = Mid(D1, i, 1)
      
     
     Next i
    Dim B() As String
    JW = 0
   ReDim B(1 To X)
   For j = 1 To X Step 1
  B(j) = Val(JW & A(j)) \ Val(D2)
    JW = Val(JW & A(j)) - Val(B(j)) * Val(D2)
     Next j
     For r = 1 To X
     If JW = 0 Then
        MCC = MCC & B(r)
        Else
        CJ = CJ & B(r)
        MCC = CJ & "/" & JW
     
  End If
  
  For i = 1 To Len(MCC)
If Not Mid(MCC, i, 1) = "0" Then
     Exit For
End If
Next
strTmp = Mid(MCC, i)
If Len(strTmp) = 0 Then
MCC = "0"
Else
MCC = strTmp
End If
  
Next

End If
   
   End If

   

End Function
Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
'加法可调用程序
Dim X, Y '两数长度
If Len(D1) >= Len(D2) Then
D4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
D4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
X = Len(d3): Y = Len(D4)
Dim A() As Integer, B1() As Integer, C1() As Integer, e1() As Integer
ReDim A(1 To X)
ReDim B1(1 To Y)
ReDim C1(1 To X)
ReDim e1(1 To X)
Dim i, j, c2, CJ, JW
For j = Y To 1 Step -1 'D2
JW = 0 '进位清0
B1(j) = Mid$(D4, j, 1) '每位数
For i = X To 1 Step -1  'D1
  A(i) = Mid$(d3, i, 1) '每位数
  C1(i) = A(i) + B1(i) + JW '计算jia
  JW = C1(i) \ 10
  e1(i) = C1(i) Mod 10
Next
Next
For r = 1 To X
If JW = 0 Then
MPC1 = MPC1 & e1(r)
Else
jc = jc & e1(r)
MPC1 = JW & jc
End If
Next

End Function


Private Sub Command1_Click()
Dim X, m
t = Timer
X = Trim(Text1)
m = fenjieyinzi0(Trim(X))
s = Len(X)

If InStr(m, "*") = 0 Then
Text2 = "这是素数， 有" & s & "位，用时 " & Timer - t & "秒"
Else
Text2 = "这是合数*， 有" & s & "位，用时 " & Timer - t & "秒"
End If

End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""

End Sub