|
|
Private Sub Command1_Click()
Dim x, Y, z
m = Text2
x = 1
Do While x < Val(m) / 2 + 1
Y = Val(m) - x
z = Sqr(x ^ 2 + Y ^ 2)
If InStr(z, ".") = 0 Then
If MPC(MPC1(MbC(Trim(x), Trim(x)), MbC(Trim(Y), Trim(Y))), MbC(Trim(z), Trim(z))) = 0 Then
s = s & "/" & x ^ 2 & "/" & Y ^ 2
s2 = "/" & z ^ 2
s1 = s1 + 1
Else
s1 = s1
End If
Else
s1 = s1
End If
x = x + 1
Loop
s3 = paixu0(Trim(s2), Trim(s))
s4 = Split(s3, "/")
J = UBound(s4)
Text1 = Text1 & "有" & J + 1 & "组解： " & s
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
End Sub
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
Private Function paixu0(a As String, B As String) As String
Dim i As Integer
Dim ak(), s105, cr(), f, bk()
s103 = a
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
s205 = Split(B, "/")
j1 = UBound(s105)
j2 = UBound(s205)
Print j1
For k = 1 To j1
n1 = n1 + 1
ReDim Preserve ak(1 To n1)
ak(n1) = s105(n1)
Next
For k = 1 To j2
n2 = n2 + 1
ReDim Preserve bk(1 To n2)
bk(n2) = s205(n2)
Next
Print ak(1)
n = 0
For k = 1 To j1
For i = 1 To j1
n = n + 1
ReDim Preserve cr(1 To n)
m = Val(ak(k)) + Val(bk(i))
f(m) = ""
If instruction(Sqr(Val(m)), ".") = 0 Then
s22 = s22 & "/" & m
Else
s22 = s22
End If
Next
Next
n = 0
m = f.Keys
For i = 0 To j1
ReDim Preserve cr(1 To i + 1)
cr(i + 1) = m(i)
Next
For i = 1 To UBound(cr) - 1
For J = i + 1 To UBound(cr)
If cr(i) > cr(J) Then
temp = cr(J)
cr(J) = cr(i)
cr(i) = temp 'c数组是排序好的
End If
Next J
' If i Mod 20 = 0 Then
' s104 = s104 & temp & "/" & vbCrLf
' Else
' s104 = s104 & temp & "/"
' End If
Next i
For i = 1 To UBound(cr)
If i Mod 20 = 0 Then
s104 = s104 & cr(i) & "/" & vbCrLf
Else
s104 = s104 & cr(i) & "/"
End If
Next
Print temp
MsgBox "ok"
MsgBox s104 '显示数组
paixu0 = s22
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
|
|
IP卡
狗仔卡
发表于 2021-2-20 06:46
显身卡
楼主