[讨论]自编程序对大素数的判断

ysr · 发表于 2026-11-1 22:27

92568222856376731590410384101 *这是合数，有29位，用时0.671875秒

8568875882787827544372149422607067562321929316290353578213 *这是合数，有58位，用时7.078125秒

73425633894622870812912264279427304662415407498217399761627450589750429468816261632146658967160832384997092708273373 *这是合数，有116位，用时81.9375秒

（这是几年以前做的程序速度太慢，后来做的一个可以再1秒内判断一个100位左右的素数的程序在单位电脑上已经被删除了，找不到了，不知道论坛是否有代码）

ysr · 发表于 2026-11-2 12:31

速度与前楼相当的代码如下：

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 · 发表于 2026-11-2 17:02

73425633894622870812912264279427304662415407498217399761627450589750429468816261632146658967160832384997092708273373 这是合数*，有116位，用时 122.2148秒
这是快速程序的结果（主要是除法用了快速除法），咋还没有以前的判断程序快啊？需要继续研究。

ysr · 发表于 2026-11-2 17:04

本帖最后由 ysr 于 2026-11-2 09:57 编辑

新修改的快速程序，代码如下：（主要是修改了一下快速除法）

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
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
ElseIf Len(D1) - Len(D2) >= 1 And Len(D1) - Len(D2) <= 4 Then
ls = Len(D1) - Len(D2)
Dim la(), lb()
ReDim la(1 To ls + 1)
ReDim lb(1)
lb(1) = Mid(D2, 1, 1)
For i1 = 1 To ls + 1
la(i1) = Mid(D1, i1, 1)
jws1 = jws1 & la(i1)
Next
jss1 = Val(jws1) \ Val(lb(1))
Do While MBJC(MbC(Trim(D2), Val(jss1)), D1) > 0
jss1 = jss1 - 1
Loop

If MPC(Trim(D1), MbC(Trim(D2), Val(jss1))) = 0 Then
MCC1 = Val(jss1)
Else
MCC1 = Val(jss1) & "/" & MPC(Trim(D1), MbC(Trim(D2), Val(jss1)))
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 · 发表于 2026-11-2 17:09

92568222856376731590410384101 这是合数*，有29位，用时 2.085938秒
8568875882787827544372149422607067562321929316290353578213 这是合数*，有58位，用时 6.640625E-02秒（对了，增加了对某些小素因子的排除程序，对某些合数速度快了不少）

ysr · 发表于 2026-11-2 18:06

分解网站现在不再可靠了，这个合数就无法分解了？如下是我的程序分解的：
8568875882787827544372149422607067562321929316290353578213=13*659144298675986734182473032508235966332456101253104121401

ysr · 发表于 2026-11-2 18:11

这个道是给分解了：
659144298675986734182473032508235966332456101253104121401=4987*1824577*72440082417275168431626856434237054240489763099<47>

ysr · 发表于 2026-11-2 18:12

72440082417275168431626856434237054240489763099 这是素数，有47位，用时 4.867188秒

		自动登录	找回密码
密码			注册