|
|
楼主 |
发表于 2023-1-20 18:08
|
显示全部楼层
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 & "组解： " & s3
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 InStr(Sqr(Val(m)), ".") = 0 Then
s22 = s22 & "/" & m
Else
s22 = s22
End If
Next
Next
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
这个代码输入11608511999，拆分3个平方数的和也是平方数居然无解 |
|
IP卡
狗仔卡
显身卡