|
#2
ysr28572021-12-02 14:44
下面发一下代码（太长如果一次传不了，就分段传）：
Dim sng As Integer 'shuru zifu & '"√"41420 '具体方法是:先切换到非英语输入法(如:五笔/拼音), '然后在输入法的状态栏上看到像键盘一样的按钮,在按钮上按右键,选"希腊字母", '根着你就可在软键盘上看到你要的符号了. '2"178",3"179",×"215",÷"247",°"176" Private Sub Command1_Click() Dim ja, jb, jc k = DeleteSpace(Text1.Text) ja = DeleteSpace(Text2.Text) jb = DeleteSpace(Text3.Text) jc = DeleteSpace(Text7.Text) sd1 = DeleteSpace(Text10.Text) If Abs(Val(sd1)) <= 10 Then sd = 10 + 2 Else If Len(sd1) > 3 And Abs(Val(sd1)) > 300 Then sd = 300 + 2 Else sd = Int(Abs(Val(sd1))) + 2 End If End If a2 = zhengliys2(Trim(ja), Val(sd)) b2 = zhengliys2(Trim(jb), Val(sd)) C2 = zhengliys2(Trim(jc), Val(sd)) k2 = zhengliys2(Trim(k), Val(sd)) If MBJC(Trim(k2), 0) = 0 Then Text4.Text = "a 不能为 0" Text5.Text = "a 为 0可能已不是1元3次方程" Else a3 = mcc2(Trim(a2), Trim(k2), Val(sd)) b3 = mcc2(Trim(b2), Trim(k2), Val(sd)) C3 = mcc2(Trim(C2), Trim(k2), Val(sd)) ' m = 36 * Val(ja) * Val(jb) - 8 * Val(ja) ^ 3 - 108 * Val(jc) If mbjc2(Trim(a3), 0) = 0 And mbjc2(Trim(b3), 0) = 0 Then m = mbc2(-108 & String(sd, "0"), Trim(C3), Val(sd)) n4 = qdfh(mbc2(Trim(m), Trim(m), Val(sd))) Else m1 = mbc2(mbc2(Trim(a3), Trim(b3), Trim(sd)), Val(36) & String(sd, "0"), Val(sd)) m2 = mbc2(mbc2(mbc2(Trim(a3), Trim(a3), Trim(sd)), Trim(a3), Val(sd)), Val(8) & String(sd, "0"), Val(sd)) m3 = mbc2(Trim(C3), Val(108) & String(sd, "0"), Val(sd)) m = mpc2(mpc2(Trim(m1), Trim(m2)), Trim(m3)) Print "m="; m 'n1 = Val(m) ^ 2 + (12 * Val(B) - 4 * Val(A) ^ 2) ^ 3 n1 = mbc2(Trim(m), Trim(m), Val(sd)) n2 = mpc2(mbc2(Trim(b3), Val(12) & String(sd, "0"), Val(sd)), mbc2(mbc2(Trim(a3), Trim(a3), Val(sd)), Val(4) & String(sd, "0"), Val(sd))) n3 = mbc2(mbc2(Trim(n2), Trim(n2), Val(sd)), Trim(n2), Val(sd)) n4 = mpc3(Trim(n1), Trim(n3)) End If fn4 = fhys(Trim(n4)) n5 = mbbc2(qqdl(qdfh(Trim(n4))), Val(sd)) Print "n5="; n5 'If n1 < 0 And m < 0 Then If Val(fn4) < 0 And Val(fhys(Trim(m))) < 0 Then 'n=(93312R^6+311040R^5+285120R^4+221824R^3+27020R^2+3712R+320)^(1/2) 'a=-(2+81k) 'm=216r^3+360r^2+128r-8 'k=(n^2/m^2)/27 ''a1=(M/8*(9t-1))^(1/3),,b1=a1*(t)^(1/2) '令m=19683N^6+1215N^4M^2+17N^2M^4-M^6, 'm1=243N^4+3N^2M^2+M^4, 'n=(m^2-m1^3)^(1/2), '则:t=(((m+n)^(1/3)+(m-n)^(1/3))+(2*M^2+3*N^2))/(3*M^2), ''其中M≠m，N≠n， jq = mbbc3(mbbc2(qqdl(MPC1(mbc2(qdfh(Trim(m)), qdfh(Trim(m)), Val(sd)), mbc2(qdfh(Trim(n5)), qdfh(Trim(n5)), Val(sd)))), Val(sd)), Val(sd)) jq3 = mcc2(Trim(n5), Trim(m), Val(sd)) jq1 = jsfanzq(mcc2(Trim(n5), Trim(m), Val(sd)), Val(sd)) Print "jq3="; jq3 Print "jq1="; jq1 q1 = mbc2(Trim(jq), jsyuxian(mcc2(Trim(jq1), 3 & String(sd, "0"), Val(sd)), Val(sd)), Val(sd)) Print "q1="; q1 If Val(fhys(Trim(q1))) > 0 Then q = tjfh(Trim(q1), Val(-1)) Else q = qdfh(Trim(q1)) End If jq3 = mbbc2(MPC(1 & String(sd, "0"), mbc2(jsyuxian(mcc2(Trim(jq1), 3 & String(sd, "0"), Val(sd)), Val(sd)), jsyuxian(mcc2(Trim(jq1), 3 & String(sd, "0"), Val(sd)), Val(sd)), _ Val(sd))), Val(sd)) jq2 = tjfh(Trim(jq3), Val(-1)) Print "jq2="; jq2 qa = mbc2(Trim(jq), Trim(jq2), Val(sd)) p = q pa = qa Else 'If n1 < 0 And m > 0 Then If Val(fn4) < 0 And MBJC(qdfh(Trim(m)), 0) > 0 Then jq = mbbc3(mbbc2(qqdl(MPC1(mbc2(qdfh(Trim(m)), qdfh(Trim(m)), Val(sd)), mbc2(qdfh(Trim(n5)), qdfh(Trim(n5)), Val(sd)))), Val(sd)), Val(sd)) jq1 = jsfanzq(mcc2(Trim(n5), Trim(m), Val(sd)), Val(sd)) jq3 = mcc2(Trim(n5), Trim(m), Val(sd)) q = mbc2(Trim(jq), jsyuxian(mcc2(Trim(jq1), 3 & String(sd, "0"), Val(sd)), Val(sd)), Val(sd)) jq2 = mbbc2(MPC(1 & String(sd, "0"), mbc2(jsyuxian(mcc2(Trim(jq1), 3 & String(sd, "0"), Val(sd)), Val(sd)), jsyuxian(mcc2(Trim(jq1), 3 & String(sd, "0"), Val(sd)), Val(sd)), _ Val(sd))), Val(sd)) Print "jq3="; jq3 Print "jq1="; jq1 Print "q"; q Print "jq2="; jq2 qa = mbc2(Trim(jq), Trim(jq2), Val(sd)) p = q pa = qa Else 'If Val(m) + Val(n2) < 0 Then If fhys(mpc3(Trim(m), Trim(n5))) = -1 Then p = "-" & mbbc3(qdfh(mpc3(Trim(m), Trim(n5))), Val(sd)) Else p = mbbc3(mpc3(Trim(m), Trim(n5)), Val(sd)) End If 'If Val(m) < Val(n2) Then If mbjc2(Trim(m), Trim(n5)) = -1 Then 'q = -(Val(n2) - Val(m)) ^ (1 / 3) q = "-" & mbbc3(qdfh(mpc2(Trim(n5), Trim(m))), Val(sd)) Else q = mbbc3(mpc2(Trim(m), Trim(n5)), Val(sd)) End If End If End If 'If a = 0 And b = 0 Then If Val(fn4) > 0 And mbjc2(Trim(n4), 0) <> 0 Then 'Val(n4) > 0 Or mbjc2(Trim(n4), 0) = 0 tx1 = mcc2(mpc2(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 2 & String(sd, "0"), Val(sd))), 6 & String(sd, "0"), Val(sd)) ftx1 = fhys(Trim(tx1)) tx4 = mcc2(mpc3(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 4 & String(sd, "0"), Val(sd))), 12 & String(sd, "0"), Val(sd)) If Val(fhys(Trim(tx4))) > 0 Then tx2 = tjfh(Trim(tx4), Val(-1)) Else tx2 = qdfh(Trim(tx4)) End If ' -(Val(p) + Val(q) + 4 * Val(A)) / 12 & "+" & Abs((3 ^ (1 / 2) * (Val(p) - Val(q)))) / 12 & "i数据太大有误差" ' -(Val(p) + Val(q) + 4 * Val(A)) / 12 & "-" & Abs((3 ^ (1 / 2) * (Val(p) - Val(q)))) / 12 & "i可选大数据高精度的" tx3 = zhengchuqy(MCC1(qdfh(mbc2(mpc2(Trim(p), Trim(q)), zhengchuqy(MBBC(3 & String(2 * Val(sd), "0"))), Val(sd))), 12)) Text4.Text = shuchujg(Trim(tx1), Val(sd)) Text5.Text = shuchujg(Trim(tx2), Val(sd)) Text6.Text = shuchujg(Trim(tx2), Val(sd)) Text8.Text = shuchujg(Trim(tx3), Val(sd)) & "i" Text9.Text = shuchujg(Trim(tx3), Val(sd)) & "i" Else If Mid(fn4, 1, 1) = "-" And Trim(m) = 0 Or Trim(n5) = 0 Then tx1 = mcc2(mpc2(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 2 & String(sd, "0"), Val(sd))), 6 & String(sd, "0"), Val(sd)) ftx1 = fhys(Trim(tx1)) tx4 = mcc2(mpc3(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 4 & String(sd, "0"), Val(sd))), 12 & String(sd, "0"), Val(sd)) ' -(Val(p) + Val(q) + 4 * Val(A)) / 12 & "+" & Abs((3 ^ (1 / 2) * (Val(p) - Val(q)))) / 12 & "i数据太大有误差" ' -(Val(p) + Val(q) + 4 * Val(A)) / 12 & "-" & Abs((3 ^ (1 / 2) * (Val(p) - Val(q)))) / 12 & "i可选大数据高精度的" tx3 = mcc2(mbc2(mpc2(Trim(p), Trim(q)), zhengchuqy(MBBC(3 & String(2 * Val(sd), "0"))), Val(sd)), 12 & String(sd, "0"), Val(sd)) If Val(fhys(Trim(tx4))) > 0 Then tx2 = tjfh(Trim(tx4), Val(-1)) Else tx2 = qdfh(Trim(tx4)) End If Text4.Text = shuchujg(Trim(tx1), Val(sd)) Text5.Text = shuchujg(mpc3(Trim(tx2), Trim(tx3)), Val(sd)) Text6.Text = shuchujg(mpc2(Trim(tx2), Trim(tx3)), Val(sd)) Text8.Text = "" Text9.Text = "" Else 'd = mcc2(mpc2(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 2 & String(sd, "0"), Val(sd))), 6 & String(sd, "0"), Val(sd)) 'd = mcc2(MPC(qdfh(mbc2(Trim(a3), 2 & String(sd, "0"), Val(sd))), mpc3(Trim(p), Trim(q))), 6 & String(sd, "0"), Val(sd)) 'mpc2减法器有问题？ 'fd = fhys(Trim(d)) tx1 = mcc2(mpc2(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 2 & String(sd, "0"), Val(sd))), 6 & String(sd, "0"), Val(sd)) ftx1 = fhys(Trim(tx1)) tx4 = mcc2(mpc3(mpc3(Trim(p), Trim(q)), mbc2(Trim(a3), 4 & String(sd, "0"), Val(sd))), 12 & String(sd, "0"), Val(sd)) ' -(Val(p) + Val(q) + 4 * Val(A)) / 12 & "+" & Abs((3 ^ (1 / 2) * (Val(p) - Val(q)))) / 12 & "i数据太大有误差" ' -(Val(p) + Val(q) + 4 * Val(A)) / 12 & "-" & Abs((3 ^ (1 / 2) * (Val(p) - Val(q)))) / 12 & "i可选大数据高精度的" tx3 = mcc2(mbc2(mpc3(Trim(pa), Trim(qa)), zhengchuqy(MBBC(3 & String(2 * Val(sd), "0"))), Val(sd)), 12 & String(sd, "0"), Val(sd)) If Val(fhys(Trim(tx4))) > 0 Then tx2 = tjfh(Trim(tx4), Val(-1)) Else tx2 = qdfh(Trim(tx4)) End If Text4.Text = shuchujg(Trim(tx1), Val(sd)) Text5.Text = shuchujg(mpc3(Trim(tx2), Trim(tx3)), Val(sd)) Text6.Text = shuchujg(mpc2(Trim(tx2), Trim(tx3)), Val(sd)) Text8.Text = "" Text9.Text = "" End If End If End If Label3.Caption = Val(Label3.Caption) + 1 Label2.Caption = "输出结果" If Text8.Text = "" Then Text11.Text = Text11.Text & " 输入" & Label3.Caption & ": " & "a=" & k & ", b=" & ja & ", c=" & jb & ", d=" & jc _ & "; 输出结果" & Label3.Caption & ": " & "x1=" & Text4.Text & ", x2=" & Text5.Text & ", x3=" & Text6.Text _ & " m=" & shuchujg(Trim(m), Val(sd)) & " n=" & shuchujg(Trim(n5), Val(sd)) & "i" Else Text11.Text = Text11.Text & " 输入" & Label3.Caption & ": " & "a=" & k & ", b=" & ja & ", c=" & jb & ", d=" & jc _ & "; 输出结果" & Label3.Caption & ": " & "x1=" & Text4.Text & ", x2=" & Text5.Text & "+" & Text8.Text & ", x3=" & Text6.Text & "-" & Text9.Text _ & " m=" & shuchujg(Trim(m), Val(sd)) & " n=" & shuchujg(Trim(n5), Val(sd)) End If End Sub Private Sub Command10_Click() Text11.Text = "1，最好输入数值 2，鲍丰武原理，王彦会程序设计 " _ & "3，编制于2013.05.02 4，有需要的请与我们联系 5，原理见《数学中国》" _ & "论坛，“风花飘飘”版作品6,兼容1元1次/2次/3次方程" Label2.Caption = "提示2" End Sub Private Sub Command11_Click() Text11.Text = "" End Sub Private Sub Command2_Click() Text1.Text = "" Text2.Text = "" Text3.Text = "" Text4.Text = "" Text5.Text = "" Text6.Text = "" Text7.Text = "" Text8.Text = "" Text9.Text = "" End Sub Private Function jspaizh(sd As String) As String '派/2=1+1/3+1*2/3*5+1*2*3/3*5*7+…… '应该是 Pi/4=1-1/3+1/5-1/7+…+（-1）^(n-1)/(2*n-1)吧，呵呵 '派/2=2/1*2/3*4/3*4/5^^^^^=2*2/1*3*4*4/3*5*6*6/5*7*^^^^^^^ Dim s1 As String s1 = "31415926535 8979323846 2643383279 5028841971 6939937510 5820974944 5923078164 0628620899 8628034825 3421170679 8214808651 32823066470938446095 5058223172 5359408128 4811174502 8410270193 8521105559 6446229489 5493038196 4428810975 6659334461 2847564823 37867831652712019091 4564856692 3460348610 4543266482 1339360726 0249141273 7245870066 0631558817 4881520920 9628292540 9171536436 7892590360" _ & "0113305305 4882046652 1384146951 9415116094 3305727036 5759591953 0921861173 8193261179 3105118548 0744623799 6274956735 1885752724" _ & "8912279381 8301194912 9833673362 4406566430 8602139494 6395224737 1907021798 6094370277 0539217176 2931767523 8467481846 7669405132" _ & "0005681271 4526356082 7785771342 7577896091 7363717872 1468440901 2249534301 4654958537 1050792279 6892589235 4201995611 2129021960" _ & "8640344181 5981362977 4771309960 5187072113 4999999837 2978049951 0597317328 1609631859 5024459455 3469083026 4252230825 3344685035" s2 = DeleteSpace(s1) jspaizh = zhengchuqy(MCC1(Left(s2, Val(sd) + 1), Val(2))) End Function Private Function zhengliys3(sa As String, sd As String) As String fa1 = fhys(Trim(sa)) If Trim(sa) = 0 Then zhengliys3 = 0 Else a2 = qqdl(ydxsd(qdfh(Trim(sa)), Val(sd))) zhengliys3 = tjfh(Trim(a2), Trim(fa1)) End If End Function Private Function zhengliys2(sa As String, sd As String) As String If sa = "" Or sa = "Text1" Or sa = "Text2" Or sa = "Text3" Or sa = "Text7" Then zhengliys2 = 0 Else If Len(sa) <= 2 And InStr(sa, "√") = 0 Then zhengliys2 = zhengliys3(Trim(sa), Val(sd)) Else If InStr(sa, "(") = 0 Then a1 = 1 B1 = 1 sa1 = sa Else If InStr(sa, "(") = 1 Then a1 = 1 sa1 = Mid(sa, InStr(sa, "(") + 1, InStr(sa, ")") - 2) B1 = Mid(sa, InStr(sa, ")") + 2) Else a1 = Left(sa, InStr(sa, "(") - 1) B1 = Mid(sa, InStr(sa, ")") + 2) sa1 = Mid(sa, InStr(sa, "(") + 1, InStr(sa, ")") - 2 - Val(Len(a1))) End If End If If a1 = "+" Then a1 = 1 Else If a1 = "-" Then a1 = -1 Else a1 = a1 End If End If If B1 = "" Or Val(B1) = 0 Then B1 = 1 Else B1 = B1 End If 'If Val(Len(Mid(sa, InStr(sa, ")")))) = 1 Or Val(Len(Mid(sa, InStr(sa, ")")))) = 2 Then 'b1 = 1 If InStr(sa1, "+") = 0 And InStr(sa1, "-") = 0 Then sa2 = zhengliys(Trim(sa1), Val(sd)) Else If InStr(sa1, "+") = 1 Or InStr(sa1, "-") = 1 Then sa3 = Mid(sa1, 2) Else sa3 = sa1 End If Do While InStr(sa3, "+") > 0 Or InStr(sa3, "-") > 0 If InStr(sa3, "+") < InStr(sa3, "-") And InStr(sa3, "+") >= 1 Then If sa3 = sa1 Then sa4 = Left(sa1, InStr(sa3, "+") - 1) Else sa4 = Left(sa1, InStr(sa3, "+")) End If sa1 = Mid(sa3, InStr(sa3, "+")) Else If InStr(sa3, "-") < InStr(sa3, "+") And InStr(sa3, "-") >= 1 Then sa4 = Left(sa1, InStr(sa3, "-")) sa1 = Mid(sa3, InStr(sa3, "-")) Else If InStr(sa3, "-") = 0 And InStr(sa3, "+") > 0 Then sa4 = Left(sa1, InStr(sa3, "+")) 'sa1 = Mid(sa3, InStr(sa3, "+") + Val(Len(a1)) - Val(Len(a3))) sa1 = Mid(sa3, InStr(sa3, "+")) Else If InStr(sa3, "-") > 0 And InStr(sa3, "+") = 0 Then sa4 = Left(sa1, InStr(sa3, "-")) sa1 = Mid(sa3, InStr(sa3, "-")) End If End If End If End If sa2 = mpc3(zhengliys(Trim(sa4), Val(sd)), Trim(sa2)) If InStr(sa1, "+") = 1 Or InStr(sa1, "-") = 1 Then sa3 = Mid(sa1, 2) Else sa3 = sa1 End If sa1 = sa1 Print sa4 Loop Print sa1 sa2 = mpc3(Trim(sa2), zhengliys(Trim(sa1), Val(sd))) Print sa2 End If zhengliys2 = mcc2(mbc2(zhengliys(Trim(a1), Val(sd)), Trim(sa2), Val(sd)), zhengliys(Trim(B1), Val(sd)), Val(sd)) End If End If End Function Private Function zhengliys(sa As String, sd As String) As String js = Right(sa, 1) If js = "+" Or js = "-" Then sa = Mid(sa, 1, Len(sa) - 1) Else sa = sa End If If InStr(sa, "/") = 0 Then B1 = 1 a2 = sa Else B1 = Mid(sa, InStr(sa, "/") + 1) a2 = Left(sa, InStr(sa, "/") - 1) End If If B1 = "" Or Val(B1) = 0 Then B1 = 1 Else B1 = B1 End If If InStr(a2, "√") = 0 Then C1 = a2 a1 = 1 Else If InStr(a2, "√") = 1 Then C1 = 1 a1 = Mid(a2, InStr(a2, "√") + 1) Else C1 = Left(a2, InStr(a2, "√") - 1) If Len(C1) = 1 And InStr(C1, "-") = 1 Then C1 = -1 Else If Len(C1) = 1 And InStr(C1, "+") = 1 Then C1 = 1 Else C1 = C1 End If End If a1 = Mid(a2, InStr(a2, "√") + 1) End If End If a1 = zhengliys3(Trim(a1), Val(sd)) B1 = zhengliys3(Trim(B1), Val(sd)) C1 = zhengliys3(Trim(C1), Val(sd)) zhengliys = mcc2(mbc2(mbbc2(Trim(a1), Val(sd)), Trim(C1), Val(sd)), Trim(B1), Val(sd)) End Function Private Function jsfanzq(sa As String, sd As String) As String If MBJC(qdfh(Trim(sa)), 1 & String(sd, "0")) = 0 Then jsfanzq = zhengchuqy(MCC1(jspaizh(sd), Val(2))) Else If MBJC(qdfh(Trim(sa)), 1 & String(sd, "0")) = 1 Then sa1 = zhengchuqy(MCC1(1 & String(2 * Val(sd), "0"), qdfh(Trim(sa)))) Else sa1 = qdfh(Trim(sa)) End If Dim s1 s1 = 1 & String(Val(sd), "0") s2 = mbc2(Trim(sa1), Trim(sa1), Val(sd)) fs1 = -1 s3 = 3 Do While MBJC(zhengchuqy(MCC1(Trim(s1), Val(s3))), 1) >= 0 s1 = mbc2(Trim(s1), Trim(s2), Val(sd)) s = mpc3(Trim(s), tjfh(zhengchuqy(MCC1(Trim(s1), Val(s3))), Val(fs1))) s3 = Val(Val(s3) + 2) fs1 = Val(-1) * Val(fs1) Loop js4 = mbc2(Trim(sa1), mpc3(Val(1) & String(Val(sd), "0"), Trim(s)), Val(sd)) fsa = fhys(Trim(sa)) If MBJC(qdfh(Trim(sa)), 1 & String(sd, "0")) = 1 Then jsfanzq = tjfh(mpc2(jspaizh(sd), Trim(js4)), Val(fsa)) Else jsfanzq = tjfh(Trim(js4), Val(fsa)) End If End If End Function Private Function jsyuxian(sa As String, sd As String) As String If MBJC(qdfh(Trim(sa)), 1 & String(sd, "0")) = 1 Then jsyuxian = jszhxian(MPC(jspaizh(Val(sd)), qdfh(Trim(sa))), Val(sd)) Else Dim s1 s1 = 1 & String(Val(sd), "0") s2 = mbc2(Trim(sa), Trim(sa), Val(sd)) fs1 = -1 s3 = 2 Do While MBJC(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), 1) >= 0 s1 = mbc2(Trim(s1), Trim(s2), Val(sd)) s = mpc3(Trim(s), tjfh(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), Val(fs1))) s3 = Val(Val(s3) + 2) fs1 = Val(-1) * Val(fs1) Loop jsyuxian = mpc3(Val(1) & String(Val(sd), "0"), Trim(s)) End If End Function Private Function jszhxian(sa As String, sd As String) As String Dim s1 s1 = 1 & String(Val(sd), "0") s2 = mbc2(Trim(sa), Trim(sa), Val(sd)) fs1 = -1 s3 = 3 Do While MBJC(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), 1) >= 0 s1 = mbc2(Trim(s1), Trim(s2), Val(sd)) s = mpc3(Trim(s), tjfh(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), Val(fs1))) s3 = Val(Val(s3) + 2) fs1 = Val(-1) * Val(fs1) Loop jszhxian = mbc2(Trim(sa), mpc3(Val(1) & String(Val(sd), "0"), Trim(s)), Val(sd)) 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 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 Public Function MBBC(D1 As String) As String 'kai pingfang If Len(D1) < 10 Then jss = Int(Sqr(Val(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) > Len(D2) Then MBJC = 1 Else If Len(D1) < Len(D2) Then MBJC = -1 Else If Len(D1) = Len(D2) And Len(D1) >= 10 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 If Len(D1) < 10 Then ja = Val(D1) - Val(D2) If ja > 0 Then MBJC = 1 Else If ja = 0 Then MBJC = 0 Else MBJC = -1 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 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 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 DeleteSpace(Tmp As String) As String Dim Inst As Integer Do Tmp = Replace(Tmp, " ", "") DoEvents Inst = InStr(Tmp, " ") Loop While Inst > 0 DeleteSpace = Tmp 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 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 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 ja = Val(D1) \ Val(D2) If Val(D1) - (Val(D1) \ Val(D2)) * Val(D2) = 0 Then MCC = ja Else MCC = ja & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2) 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 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 ydxsd(sa As String, sd As String) As String If Len(sa) = 1 And Trim(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 fhys(sa As String) As String If InStr(sa, "-") = 0 Then fhys = 1 Else fhys = -1 End If End Function Private Function tjfh(sa As String, sf As String) As String 'qianjia fuhao If Val(sf) < 0 Then tjfh = "-" & sa Else tjfh = sa End If End Function Private Function jcjs(sa As String) As String Dim s s = 1 For I = 1 To sa s = MbC(Trim(s), Val(I)) Next jcjs = s End Function Private Function qdfh(sa As String) As String If InStr(sa, "-") > 0 Then qdfh = Mid(sa, 2) Else If InStr(sa, "+") > 0 Then qdfh = Mid(sa, 2) Else qdfh = sa End If End If End Function Private Function mbbc3(sa As String, sd As String) As String 'kai lifang jingdu daifh Dim ja If Val(Len(sa)) = 1 And Trim(sa) = 0 Then mbbc3 = 0 Else fh = fhys(sa) ja = MBBC1(qdfh(sa) & String(Val(sd) * 2, "0")) If InStr(ja, "/") = 0 And Val(fh) > 0 Then mbbc3 = ja Else If InStr(ja, "/") = 0 And Val(fh) < 0 Then mbbc3 = "-" & ja Else If Val(fh) > 0 Then mbbc3 = Left(ja, InStr(ja, "/") - 1) Else mbbc3 = "-" & Left(ja, InStr(ja, "/") - 1) End If End If End If End If End Function |
你若不输入要求精度，则输出结果精确到点后10位。
这个程序可能是有用，解一元四次方程的公式也是基于求解一元三次方程的方法，因为首先是根据原方程的系数解一个一元三次方程，根据解的情况再解两个等效的二次方程。
就是不断降幂。
而5次以上的方程是没有求跟公式的，只能是用牛顿迭代法求解，得到近似的数值解。超越方程也没有公式解，也是用迭代法或者叫穷举迭代法，得到近似的数值解。
下面传一下这个一元三次方程的求解程序（可以输入简单的根式或分数，不能做复杂的多层根式或分数，输入格式有提示的）：
只有本站会员才能查看附件，请 登录
