回复 58楼 wmf2014
以下是完整的代码，欢迎试用！谢谢您的帮助！有问题欢迎沟通！加了个常规判定程序，小于等于10位的都是常规法判断的，那些中文注释全变？号了，随便改了去掉？号，没有注释了，不理解的随时问我随时解释吧！长，试试能发出来不？
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 '程序
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(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 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)
If Len(n) < 11 Then
Text2 = fenjieyinzi(Trim(n))
Else
n1 = MPC(Trim(n), 1)
a = 123
'a为明文
a1 = zzxc(Trim(n), Trim(a))
If Val(a1) > 1 Then
Text2 = 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
Text2 = "这是素数有" & Len(n) & "位"
Else
Text2 = "2*2"
End If
End If
End If
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
End Sub
[此贴子已经被作者于2021-9-14 21:47编辑过]
2020-02-15 16:49
