求版主：

柳林

本人急需素数表，用于素数计算。

本人只有40亿以下的素数表，急需40亿至1000亿之间的素数表。

由于文件太大，可能有100G左右。

可以压缩后，发到我的邮箱。doudou1927@126.com

如果一次不行，也可以分几次发出。

如果用上述方法还有困难，也可以用版主认为更好的办法。

如果版主本人不方便，欢迎看到本贴的，有素数表的网友帮忙。

           谢谢

                    网友柳林

                                       2020年10月1日

ysr

普通电脑可能只能算到20亿，用筛法算的快，占内存，再大的内存会溢出吧？
你的40亿的已经不小了。要制作40亿~1000亿的素数表，怕只能是用超算才能办到吧？
判断40亿~1000亿的素数，要用到大素数的快速快速判断方法和程序。我给你发个程序代码？
我不会快速乘法和除法程序，程序不快，经过优化，100位的需要1秒。
顶起我的大素数的判断方法一文，供参考！

ysr

代码如下：（优化了一下程序，速度快了一些重发一下代码）

Private Function mbc2(sa As String, sb As String, sd As String) As String 'chengfa jingdu
  Dim ja

  If Trim(sa) = 0 Or Trim(sb) = 0 Then
  mbc2 = 0
  Else


  ja = MbC(Trim(sa), Trim(sb))
  If Val(Len(ja)) > Val(sd) Then
  jb = Left(ja, Val(Len(ja)) - Val(sd))
  mbc2 = jb
  Else
  mbc2 = 0
  End If


  End If




  End Function

Private Function qdhz0(sa As String) As String
  a = sa
  Do While Right(a, 1) = "0"
  a = Left(a, Len(a) - 1)
  Loop
  If a = "" Then
  a = 0
  Else
  a = a
  End If
  qdhz0 = a
  End Function


  Private Function qdqd0(sa As String) As String
  a = sa
  Do While Left(a, 1) = "0"
  a = Mid(a, 2)
  Loop
  If a = "" Then
  a = 0
  Else
  a = a
  End If
  qdqd0 = a
  End Function

  Private Function tjxsd(sa As String, sd As String) As String
  If Val(Len(sa)) > Val(sd) Then
  tjxsd = Left(sa, Val(Len(sa)) - Val(sd)) & "." & Mid(sa, Val(Len(sa)) - Val(sd) + 1)
  Else
  If Val(Len(sa)) = Val(sd) Then
    tjxsd = "0." & sa
    Else
    tjxsd = "0." & String(Val(sd) - Val(Len(sa)), "0") & Trim(sa)
    End If
    End If

  End Function

  Private Function ydxsd(sa As String, sd As String) As String
  If Len(sa) = 1 And Val(sa) = 0 Then
    ydxsd = 0
    Else
   
      sc = InStr(sa, ".")
      If Val(sc) = 0 Then
      ydxsd = sa & String(sd, "0")
      Else
      se = Left(sa, Val(sc) - 1)
      sf = Right(sa, Len(sa) - Val(sc))
      If Val(Len(sf)) >= Val(sd) Then
      ydxsd = se & Mid(sf, 1, sd)
        Else
        ydxsd = se & sf & String(Val(sd) - Len(sf), "0")
        End If
        End If
        End If
        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(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) <= 10 And Len(D2) <= 10 Then
If Val(D1) > Val(D2) Then
MBJC = 1
Else
If Val(D1) = Val(D2) Then
MBJC = 0
Else
MBJC = -1
End If
End If
Else

If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) 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
End If
End If
End If
End Function

Public Function MCC(D1 As String, D2 As String) As String ';除数少于8位的除法
If Len(D1) < Len(D2) Then
   MCC = "0" & "/" & D1
   Else
   If Len(D1) < 9 Then
    MCC = Val(D1) \ Val(D2) & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
     If Mid(MCC, InStr(MCC, "/") + 1) = 0 Then
  MCC = Left(MCC, InStr(MCC, "/") - 1)
Else
MCC = MCC
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 MCC4(D1 As String, D2 As String) As String ';大整数的除法
Dim a, B
  a = Trim(D1): B = Trim(D2): b3 = B: a3 = a
  If Len(B) = 1 Then
  X1 = Mid(B, 1, 1): X2 = 1 / X1 - 0.01
  Else
  X1 = Mid(B, 1, 2): X2 = 10 / X1 - 0.01
  End If
  X = Mid(X2, 1, 4)
  Y = 0: x3 = 0
  sb = Len(a3) + Len(b3) - 1 + 10
  If Len(a3) = Len(b3) And MBJC(Trim(a3), Trim(b3)) = 0 Then
  a1 = 1
  ElseIf MBJC(Mid(a3, 1, Len(b3)), Trim(b3)) = 0 And Val(Len(qdhz0(Trim(a3)))) = Val(Len(b3)) Then
  a1 = 1 & String(Len(a3) - Len(qdhz0(Trim(a3))), "0")
  Else
  
  a = a & String(10, "0"): B = B & String(10 + Len(a3), "0")
  X = qdqd0(ydxsd(Trim(X), Val(sb)))
  Y1 = 2 & String(Val(sb), "0")
  Do While MBJC(MPC(Trim(X), Trim(x3)), 1) >= 0
  
  s3 = s3 + 1
  Y = mbc2(Trim(X), MPC(Trim(Y1), mbc2(Trim(B), Trim(X), Val(sb))), Val(sb))
  x3 = X
  X = Trim(Y)
  Loop
  a1 = mbc2(Trim(Y), Trim(a), Val(sb))
  s = Len(a3) - Len(b3)
  a1 = qdqd0(Trim(a1))
  
  If MBJC(Mid(a3, 1, Len(b3)), Trim(b3)) < 0 Then
  a1 = tjxsd(Trim(a1), Len(a1) - s)
  Else
  a1 = tjxsd(Trim(a1), Len(a1) - s - 1)
  End If
  End If
  
  If InStr(a1, ".") = 0 Then
  a1 = a1
  Else
  a1 = Left(a1, InStr(a1, ".") - 1)
  End If
  ja = MPC(Trim(a3), MbC(Trim(b3), Trim(a1)))
  Do While MBJC(Trim(ja), Trim(b3)) >= 0
  ja = MPC(Trim(ja), Trim(b3))
  s5 = s5 + 1
  Loop
  a1 = MPC1(Trim(a1), Trim(s5))
  If ja = 0 Then
  MCC4 = a1
  Else
  MCC4 = a1 & "/" & ja
  End If
End Function

Public Function MCC1(D1 As String, D2 As String) As String ';大整数的除法
If Len(D1) > 300 And Len(D2) > 300 Then
MCC1 = MCC4(Trim(D1), Trim(D2))
Else


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
      
      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) = "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 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

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) \ 8: Y = Len(d4) \ 8
  If Len(D3) > 8 * X Then
  D3 = String(8 * X + 8 - Len(D3), "0") & D3
  d4 = String(8 * Y + 8 - Len(d4), "0") & d4
  X = X + 1: Y = Y + 1
  Else
  X = X: Y = Y
  D3 = D3: d4 = d4
  End If
  
  Dim a() As String, B1() As String, C1() As String, E1() As String
  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 * 8 - 7, 8) ';每位数
For I = X To 1 Step -1  ';D1
     a(I) = Mid(D3, I * 8 - 7, 8) ';每位数
   C1(I) = Val(1 & a(I)) - Val(B1(I)) - Val(1) + Val(JW) ';计算jia
     JW = C1(I) \ 10 ^ 8
     E1(I) = C1(I) Mod 10 ^ 8
     If Len(E1(I)) < 8 Then
     E1(I) = String(8 - Len(E1(I)), "0") & E1(I)
     Else
     E1(I) = E1(I)
     End If
     
    Next
    Next
    For r = 1 To X
    MPC = MPC & E1(r)
    If Len(MPC) > Len(D1) Then
    MPC = Mid(MPC, Len(MPC) - Len(D1) + 1)
    Else
    MPC = MPC
    End If
    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 MPC1(D1 As String, D2 As String) As String 'jiafa
  Dim X, Y, JW '两数长度

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) \ 8: Y = Len(d4) \ 8
  If 8 * X < Len(D3) Then
  D3 = String(8 * X + 8 - Len(D3), "0") & D3
  d4 = String(8 * Y + 8 - Len(d4), "0") & d4
  X = X + 1: Y = Y + 1
  Else
  X = X: Y = Y
  D3 = D3: d4 = d4
  End If
  Dim a() As String, B1() As String, C1() As String, E1() As String
  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
  For J = Y To 1 Step -1 'D2
  JW = 0 '进位清0
  B1(J) = Mid$(d4, J * 8 - 7, 8) '每位数
For I = X To 1 Step -1  'D1
     a(I) = Mid$(D3, I * 8 - 7, 8) '每位数
   C1(I) = Val(a(I)) + Val(B1(I)) + Val(JW) '计算jia
   If Len(C1(I)) < 8 Then
   C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
   Else
   C1(I) = C1(I)
   End If
     JW = Left(C1(I), Len(C1(I)) - 8)
     E1(I) = Right(C1(I), 8)
    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
   MPC1 = qqdl(Trim(MPC1))
  End Function

Private Function qqdl(sa As String) As String

  
  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

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 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 = 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
X = (a + B) Mod p
  Y = (c + d) Mod n
  
  
  Else
  
  If MBJC(Trim(n), Trim(p)) >= 1 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 = 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 MPC1(Trim(a), MbC(Trim(B), Trim(m))) = p 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 MPC1(Trim(B), MbC(Trim(a), Trim(m))) = p 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
Do While Left(a, 1) = "0"
    a = Mid(a, 2)
Loop
  
  End If
  
  qniyuan = a
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 fenjieyinzi(sa As String) As String
Dim X, a, B
X = sa
B = Int(Sqr(Val(X)) / 2)
If X = 3 Or X = 2 Then
a = True
Else
If Right(X, 1) Mod 2 = 0 Then
a = False
Else

For I = 3 To 2 * B + 1 Step 2
If InStr(X / I, ".") = 0 Then
a = False
Exit For

Else: a = True

End If
Next
End If
End If
If a = True Then
fenjieyinzi = "这是个素数"
Else
fenjieyinzi = "2*2"
End If

End Function

Private Sub Command1_Click()
Dim a, n
n = Trim(Text1)
ts = Timer
If Len(n) < 11 Then
Text2 = fenjieyinzi(Trim(n))
If InStr(Text2, "*") = 0 Then
Text2 = "这是素数，有" & Len(n) & "位，用时" & Timer - ts & "位"
Else
Text2 = "*这是合数，有" & Len(n) & "位，用时" & Timer - ts & "秒"
End If
Else
n1 = MPC(Trim(n), 1)
a = 123
'a为明文
a1 = zzxc(Trim(n), Trim(a))
If Val(a1) > 1 Then
Text2 = a1 & "*这是合数，有" & Len(n) & "位，用时" & Timer - ts & "秒"
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
Text2 = "这是素数有" & Len(n) & "位，用时" & Timer - ts & "秒"
Else
Text2 = "*这是合数，有" & Len(n) & "位，用时" & Timer - ts & "秒"
End If
End If
End If
End Sub

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

End Sub

ysr

如下是优化后的可执行程序，双击就可以运行了。例如：输入233333333333333333333333333333333333333333333333333333，结果：这是素数有54位，用时3.046875秒。

ysr

4000000019~4000000050之间的素数有/4000000007这是素数有10位/4000000009这是素数有10位/4000000019这是素数有10位

ysr

4000000050~4000000200之间的素数有
/4000000063这是素数有10位
/4000000133这是素数有10位
/4000000157这是素数有10位
/4000000163这是素数有10位
/4000000187这是素数有10位

ysr

4000000000~4000000050之间的素数有3个：
/4000000007这是素数有10位
/4000000009这是素数有10位
/4000000019这是素数有10位

ysr

4000000000~4000000500之间的素数有19个：
/4000000007这是素数有10位
/4000000009这是素数有10位
/4000000019这是素数有10位
/4000000063这是素数有10位
/4000000133这是素数有10位
/4000000157这是素数有10位
/4000000163这是素数有10位
/4000000187这是素数有10位
/4000000229这是素数有10位
/4000000231这是素数有10位
/4000000241这是素数有10位
/4000000273这是素数有10位
/4000000351这是素数有10位
/4000000373这是素数有10位
/4000000387这是素数有10位
/4000000427这是素数有10位
/4000000451这是素数有10位
/4000000453这是素数有10位
/4000000483这是素数有10位

ysr

代码如下：（供参考）

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(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) <= 10 And Len(D2) <= 10 Then
If Val(D1) > Val(D2) Then
MBJC = 1
Else
If Val(D1) = Val(D2) Then
MBJC = 0
Else
MBJC = -1
End If
End If
Else

If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) 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
End If
End If
End If
End Function

Public Function MCC(D1 As String, D2 As String) As String ';除数少于8位的除法
If Len(D1) < Len(D2) Then
   MCC = "0" & "/" & D1
   Else
   If Len(D1) < 9 Then
    MCC = Val(D1) \ Val(D2) & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
     If Mid(MCC, InStr(MCC, "/") + 1) = 0 Then
  MCC = Left(MCC, InStr(MCC, "/") - 1)
Else
MCC = MCC
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 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
      
      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) = "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
Public Function MbC(D1 As String, D2 As String) As String '乘法
Dim x, Y '两数长度
x = Len(D1): Y = Len(D2)
Dim a() As Integer
ReDim a(1 To x + Y, 1 To Y)
Dim I, J, C1, C2, CJ, JW
For J = Y To 1 Step -1 'D2
JW = 0 '进位清0
C2 = Mid$(D2, J, 1) '每位数
For I = x To 1 Step -1 'D1
  C1 = Mid$(D1, I, 1) '每位数
  CJ = C1 * C2 + JW '计算乘积
  c = I + J: r = Y + 1 - J
  a(c, r) = CJ Mod 10 '本位
  JW = CJ \ 10 '进位
Next
a(c - 1, r) = JW
Next
Dim b() As Integer
ReDim b(1 To x + Y)
JW = 0
For I = x + Y To 1 Step -1
Bit = JW
For J = 1 To Y
  Bit = Bit + a(I, J)
Next
b(I) = Bit Mod 10
JW = Bit \ 10
Next
If b(1) > 0 Then
MbC = MbC & b(1)
Else
MbC = MbC
End If
For I = 2 To x + Y
MbC = MbC & b(I)
Next
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 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 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 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 = 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
x = (a + b) Mod p
  Y = (c + d) Mod n
  
  
  Else
  
  If MBJC(Trim(n), Trim(p)) >= 1 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 = 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 MPC1(Trim(a), MbC(Trim(b), Trim(m))) = p 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 MPC1(Trim(b), MbC(Trim(a), Trim(m))) = p 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
Do While Left(a, 1) = "0"
    a = Mid(a, 2)
Loop
  
  End If
  
  qniyuan = a
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 fenjieyinzi(sa As String) As String
Dim x, a, b
x = sa
b = Int(Sqr(Val(x)) / 2)
If x = 3 Or x = 2 Then
a = True
Else
If x Mod 2 = 0 Then
a = False
Else

For I = 3 To 2 * b + 1 Step 2
If x Mod I = 0 Then
a = False
Exit For

Else: a = True

End If
Next
End If
End If
If a = True Then
fenjieyinzi = "这是个素数"
Else
fenjieyinzi = "2*2"
End If

End Function


Private Sub Command1_Click()
Dim a, n
n = Trim(Text1)
n3 = n
m = Trim(Text2)
If Right(n, 1) Mod 2 = 0 Then
n = MPC1(Trim(n), 1)
Else
n = n
End If
Do While MBJC(Trim(n), Trim(m)) <= 0
If Len(n) < 11 Then
Text3 = fenjieyinzi(Trim(n))
Else
n1 = MPC(Trim(n), 1)
a = 123
'a为明文
a1 = zzxc(Trim(n), Trim(a))
If Val(a1) > 1 Then
m1 = m1
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
m1 = m1 & "/" & n & "这是素数有" & Len(n) & "位" & vbCrLf
s = s + 1
Else
m1 = m1
End If
End If
End If
n = MPC1(Trim(n), 2)
Loop
Text3 = n3 & "~" & m & "之间的素数有" & s & "个：" & vbCrLf & m1
End Sub

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

ysr

4000000500~4000001000之间的素数有24个：
/4000000531这是素数有10位
/4000000553这是素数有10位
/4000000559这是素数有10位
/4000000561这是素数有10位
/4000000573这是素数有10位
/4000000579这是素数有10位
/4000000591这是素数有10位
/4000000597这是素数有10位
/4000000607这是素数有10位
/4000000619这是素数有10位
/4000000661这是素数有10位
/4000000663这是素数有10位
/4000000687这是素数有10位
/4000000723这是素数有10位
/4000000727这是素数有10位
/4000000733这是素数有10位
/4000000787这是素数有10位
/4000000801这是素数有10位
/4000000813这是素数有10位
/4000000831这是素数有10位
/4000000861这是素数有10位
/4000000913这是素数有10位
/4000000951这是素数有10位
/4000000981这是素数有10位