[原创]大整数开立方VB程序

ysr

[这个贴子最后由ysr在 2013/04/25 03:16pm 第 3 次编辑] [watermark]如下程序可以计算立方根，取整数部分： Private Sub Command1_Click() D1 = Text1.Text jcc = MBBC1(Text1.Text) If InStr(jcc, "/") = 0 Then Text2.Text = "0" Text3.Text = MBBC1(Text1.Text) Else Text2.Text = Mid(jcc, InStr(jcc, "/")) Text3.Text = Left(jcc, InStr(jcc, "/") - 1) End If End Sub Private Sub Command1_Click() D1 = Text1.Text jcc = MBBC1(Text1.Text) If InStr(jcc, "/") = 0 Then Text2.Text = "0" Text3.Text = MBBC1(Text1.Text) Else Text2.Text = Mid(jcc, InStr(jcc, "/")) Text3.Text = Left(jcc, InStr(jcc, "/") - 1) End If End Sub Public Function MBBC1(D1 As String) As String ';kai lifang If Len(D1) < 10 Then jss = Int((D1) ^ (1 / 3)) If (Val(jss) + 1) ^ 3 - Val(D1) = 0 Then jss = Val(jss) + 1 Else jss = jss End If JW = Val(D1) - (jss) ^ 3 If JW = 0 Then MBBC1 = jss Else MBBC1 = jss & "/" & JW End If Else Dim X ';shuju changdu X = Len(D1) \ 3 D2 = String(3 - Len(D1) + 3 * X, "0") & D1 Dim A() As String ReDim A(3 To 3 * X + 3) Dim B() As String ReDim B(1 To X) Dim I, J, js For I = 3 To 3 * X + 3 Step 3 A(I) = Mid(D2, I - 2, 3) Next js = Int((Val(A(3) & A(6))) ^ (1 / 3)) If (Val(js) + 1) ^ 3 - Val(A(3) & A(6)) = 0 Then js = Val(js) + 1 Else js = js End If JW = Val(A(3) & A(6)) - (js) ^ 3 J = 2 Do While J <= X jws = MPC1(JW & "000", A(3 * J + 3)) If MBJC(Trim(jws), MPC1(MbC(MbC(MbC(Trim(js), 10), MPC1(MbC(Trim(js), 10), 1)), 3), 1)) < 0 Then B(J) = "0" Else jwc = Left(jws, 2) \ Left(MPC1(MbC(MbC(MbC(Trim(js), 10), MPC1(MbC(Trim(js), 10), 1)), 3), 1), 1) ';2=Len(jws) - Len(MbC(MbC(Trim(js), MPC1(Trim(js), 1)), 30)) + 1 If Len(jwc) > 1 Then B(J) = 9 Else B(J) = jwc End If Do While MBJC(Trim(jws), MbC(MPC1(MbC(B(J), B(J)), MbC(MbC(MbC(Trim(js), 10), MPC1(MbC(Trim(js), 10), Trim(B(J)))), 3)), B(J))) = -1 B(J) = B(J) - 1 Loop End If JW = MPC(Trim(jws), MbC(MPC1(MbC(B(J), B(J)), MbC(MbC(MbC(Trim(js), 10), MPC1(MbC(Trim(js), 10), Trim(B(J)))), 3)), B(J))) js = MPC1(MbC(Trim(js), 10), Trim(B(J))) J = J + 1 If JW = 0 Then MBBC1 = js Else MBBC1 = 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) 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 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 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 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 Sub Command2_Click() Text1.Text = "" Text2.Text = "" Text3.Text = "" End Sub 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 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 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 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 Sub Command2_Click() Text1.Text = "" Text2.Text = "" Text3.Text = "" End Sub 验证： 输入：12345678912， 余数：/3272681， 立方根：2311，[/watermark]

ysr

欢迎批评，欢迎试用！

ysr

哈哈！程序原来可以这样编，奇妙处无法形容！着是灵活的数学公式，这是永不疲倦的数学高手！

ysr

主楼程序已修改正确，欢迎试用批评！

ysr

顶一下，欢迎试用