|

楼主 |
发表于 2023-1-24 19:39
|
显示全部楼层
Private Sub Command1_Click()
Dim x, a
a1 = Val(Text1)
u = 1
Do While Val(u) <= a1
v = 1
Do While Val(v) <= a1
q = u ^ 2 - v ^ 2
p = 2 * u * v
r = 1
Do While r <= a1
a = Abs(p ^ 2 + q ^ 2 - r ^ 2)
B = 2 * p * r
c = 2 * q * r
g = p ^ 2 + q ^ 2 + r ^ 2
Y = a ^ 2 + B ^ 2 + c ^ 2
z = g ^ 2
If Val(Y) = z And a * B * c <> 0 And InStr(Sqr(a ^ 2 + B ^ 2), ".") = 0 And InStr(Sqr(c ^ 2 + B ^ 2), ".") = 0 And InStr(Sqr(a ^ 2 + c ^ 2), ".") = 0 Then
If MPC(MPC1(MbC(Trim(a), Trim(a)), MbC(Trim(B), Trim(B))), MbC(Sqr(Val(a) ^ 2 + Val(B) ^ 2), Sqr(Val(a) ^ 2 + Val(B) ^ 2))) = 0 Then
s = s & "/g=" & Sqr(z) & "a=" & a & " b=" & B & " c=" & c & vbCrLf
s1 = s1 + 1
Else
s = s
End If
Else
s = s
End If
r = r + 1
Loop
v = v + 1
Loop
u = u + 1
Loop
Text2 = "有" & Val(s1) & "组完美长方体解" & 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
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
|
|