几个快速小程序vb代码

ysr · 发表于 2021-2-3 17:55

这个就是用前面的程序很快就算出来了，我的大整数的乘法是模仿手工计算的效率慢，但仍然很快就算出来了估计就是几秒钟时间。

ysr · 发表于 2021-2-5 18:48

能算出来上万位的整数的快速幂程序代码如下：

Private Sub Command1_Click()
Dim a, b
a = Text1: b = Text2
If b = 1 Then
Text3 = a
ElseIf b = 0 Then
Text3 = 1
Else
a1 = a
Do While b > 1
s = Int(Log(b) / Log(2))
s1 = 0
Do While s1 < s
a = MbC(Trim(a), Trim(a))
s1 = s1 + 1
Loop
a2 = a
b = b - 2 ^ s
a = a1
If s2 > 0 Then
a3 = MbC(Trim(a3), Trim(a2))
Else
a3 = a2
End If
s2 = s2 + 1
Loop
If b = 1 Then
Text3 = MbC(Trim(a3), Trim(a1))
Else
Text3 = a3
End If
s3 = Len(Text3)
Text3 = Text3 & "有" & s3 & "位"
End If
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""

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

ysr · 发表于 2021-2-5 23:44

大数除法之迭代法
除法：u/y=u*(1/y)；

先讲一下倒数迭代式：x1=(2-y*x0)*x0,x0是y的倒数的近似值，它必须要小于y的倒数。另外迭代式中的乘法子程序要选用快速乘法（如FFT算法的乘法子程序）。

否则迭代法的除法速度是很慢的，远远小于估商法。
例：求 6666666/23333 。
转换问题变成求 6.666666/2.3333*10^2 。先求 1/2.333，初值设为 10/23=0.4 ,
第一次迭代： x=0.4
第二次迭代： x=0.426
第三次迭代： x=0.4285620
第四次迭代：x=0.42857755……
第五次迭代 :x=0.42857755……
需要注意的是最后的答案只有一半的位数是正确的，计算答案得到 6666666/23333=285.71833……。

ysr · 发表于 2021-2-6 00:11

本帖最后由 ysr 于 2021-2-6 00:58 编辑

实现细节：

1.为了方便可以将整数转换成多项式：a0+a1*10^-1+a2*10^-2+…………
2.类似多项式求逆，每一次计算时只需要取 b 的前 n 位参加计算，同样答案需要舍弃后面的位数。（可以直接把b的位数写全，这样稍慢些但编程简单）
3.迭代初值在（0，2/b）收敛，那么初值可以设置为答案的第一位（例如 b=7时初值设为 0.1 , b=1.23时，初值设为 0.8）。
例如上例中：
第一次迭代：x=x（2-x*2.3）=0.4
第二次迭代：x=x（2-x*2.33）=0.426
………………

ysr · 发表于 2021-2-6 00:54

验证了一下，整数部分是准确的。小数部分如何更准确，待研究了。

ysr · 发表于 2021-2-6 07:07

这回准确了，小数点后也准确，代码如下：

Private Sub Command1_Click()
Dim a, b
a = Text1: b = Text2: b3 = b
If Len(b) = 1 Then
X1 = Mid(b, 1, 1): X2 = 1 / X1
Else
X1 = Mid(b, 1, 2): X2 = 10 / X1
End If
x = Mid(X2, 1, 4)
y = 0: x3 = 0
If Len(b) = 1 Then
b = b
Else
b1 = Mid(b, 1, 1)
b2 = Mid(b, 2)
b = b1 & "." & b2
End If

Do While Abs(x3 - x) >= 0.0000000001

Print x
y = Val(x * (2 - b * x))
x3 = x
x = Val(y)
Loop
a1 = Mid(a, 1, Len(a) - Len(b3) + 1)
a2 = Right(a, Len(b3) - 1)
a = a1 & "." & a2
Print a
s = Len(a) - Len(b3)
Text3 = a * y
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""

End Sub

ysr · 发表于 2021-2-15 23:44

本帖最后由 ysr 于 2021-2-16 03:07 编辑

公式法求勾股数的程序，求a^2+b^2=c^2，且满足a+b=k的整数解：

Private Sub Command1_Click()
Dim a, b, x, y, z, m
m = Text2
b1 = m / 2
b2 = b1 / 3
s1 = 0
Do While t < Val(b2) + 2
t = t + 1
b = 0
Do While t * b ^ 2 < Val(b1) + 2
a = b
b = b + 1
Do While t * a ^ 2 < Val(m)
a = a + 1
x = t * (a ^ 2 - b ^ 2)
y = 2 * a * b * t
z = Sqr(x ^ 2 + y ^ 2)
If InStr(z, ".") = 0 And x + y = Val(m) Then
m1 = (x + z) / 2
m2 = Sqr(m1)
s = s & "/解/" & x & "/" & y & "/" & z & "其中(x + z) / 2=" & m1 & "其方根为：" & m2 & vbCrLf
s1 = s1 + 1
Else
s1 = s1
End If
Loop
Loop
Loop

Text1 = Text1 & "当x+y=" & m & "有" & s1 + s2 & "组解： " & s
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Form1.Cls
End Sub

ysr · 发表于 2021-2-17 10:52

本帖最后由 ysr 于 2021-2-17 04:58 编辑

如下除法程序小数点位置不对，需要改进：（修改了一下，这回小数点对了）
Private Sub Command1_Click() '快速除法程序
Dim a, b
a = Trim(Text1): b = Trim(Text2): b3 = b: a3 = a
If Len(b) = 1 Then
X1 = Mid(b, 1, 1): X2 = 1 / X1 - 0.01
Else
X1 = Mid(b, 1, 2): X2 = 10 / X1 - 0.01
End If
x = Mid(X2, 1, 4)
Y = 0: x3 = 0
sb = Len(a3) + Len(b3) - 1 + 10
a = a & String(20 + 2 * Len(a3), "0"): b = b & String(10 + Len(a3), "0")
x = qdqd0(ydxsd(Trim(x), Val(sb)))
Y1 = 2 & String(Val(sb), "0")
Do While MBJC(MPC(Trim(x), Trim(x3)), 1) >= 0
x6 = MPC(Trim(x), Trim(x3))
s3 = s3 + 1
Print x3, x
Y = mbc2(Trim(x), MPC(Trim(Y1), mbc2(Trim(b), Trim(x), Val(sb))), Val(sb))
x3 = x
x = Trim(Y)
Loop
a1 = mbc2(Trim(Y), Trim(a), Val(sb))
s = Len(a3) - Len(b3)
a1 = qdqd0(Trim(a1))
If Len(b3) = 1 Then
a1 = tjxsd(Trim(a1), Len(a1) - s)
Else
a1 = tjxsd(Trim(a1), Len(a1) - s - 1)
End If
Text3 = a1
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""

End Sub
Private Function mbc2(sa As String, sb As String, sd As String) As String 'chengfa jingdu
Dim ja

If sa = 0 Or sb = 0 Then
mbc2 = 0
Else

ja = MbC(Trim(sa), Trim(sb))
If Val(Len(ja)) > Val(sd) Then
jb = Left(ja, Val(Len(ja)) - Val(sd))
mbc2 = jb
Else
mbc2 = 0
End If

End If

End Function

Private Function qdqd0(sa As String) As String
a = sa
Do While Left(a, 1) = "0"
a = Mid(a, 2)
Loop
If a = "" Then
a = 0
Else
a = a
End If
qdqd0 = a
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

Private Function ydxsd(sa As String, sd As String) As String
If Len(sa) = 1 And Val(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

   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

Public Function MBJC(D1 As String, D2 As String) As String ';bijiao
If Len(D1) <= 10 And Len(D2) <= 10 Then
If Val(D1) > Val(D2) Then
MBJC = 1
Else
If Val(D1) = Val(D2) Then
MBJC = 0
Else
MBJC = -1
End If
End If
Else

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 If
End Function

ysr · 发表于 2021-2-17 15:11

本帖最后由 ysr 于 2021-2-18 14:21 编辑

只输出整数部分和余数的快速除法程序，几百位的整数可以瞬间完成，最大不知道算到多少位：
（其中的乘法是模仿手工计算的速度慢，所以还有很大的提升空间）（不知道有没有错误的情况，欢迎试用和批评指导！）(修改了一下，关键是移动小数点有一类错误，已经改好，谁知道还有没有错误的类型？)

Private Sub Command1_Click() '快速除法程序
Dim a, b
  a = Trim(Text1): b = Trim(Text2): b3 = b: a3 = a
  If Len(b) = 1 Then
  X1 = Mid(b, 1, 1): X2 = 1 / X1 - 0.01
  Else
  X1 = Mid(b, 1, 2): X2 = 10 / X1 - 0.01
  End If
  x = Mid(X2, 1, 4)
  Y = 0: x3 = 0
  sb = Len(a3) + Len(b3) - 1 + 10
  If Len(a3) = Len(b3) And MBJC(Trim(a3), Trim(b3)) = 0 Then
  a1 = 1
  ElseIf MBJC(Mid(a3, 1, Len(b3)), Trim(b3)) = 0 And Val(Len(qdhz0(Trim(a3)))) = Val(Len(b3)) Then
  a1 = 1 & String(Len(a3) - Len(qdhz0(Trim(a3))), "0")
  Else

  a = a & String(10, "0"): b = b & String(10 + Len(a3), "0")
  x = qdqd0(ydxsd(Trim(x), Val(sb)))
  Y1 = 2 & String(Val(sb), "0")
  Do While MBJC(MPC(Trim(x), Trim(x3)), 1) >= 0

  s3 = s3 + 1
  Y = mbc2(Trim(x), MPC(Trim(Y1), mbc2(Trim(b), Trim(x), Val(sb))), Val(sb))
  x3 = x
  x = Trim(Y)
  Loop
  a1 = mbc2(Trim(Y), Trim(a), Val(sb))
  s = Len(a3) - Len(b3)
  a1 = qdqd0(Trim(a1))

  If MBJC(Mid(a3, 1, Len(b3)), Trim(b3)) < 0 Then
  a1 = tjxsd(Trim(a1), Len(a1) - s)
  Else
  a1 = tjxsd(Trim(a1), Len(a1) - s - 1)
  End If
  End If

  If InStr(a1, ".") = 0 Then
  a1 = a1
  Else
  a1 = Left(a1, InStr(a1, ".") - 1)
  End If
  ja = MPC(Trim(a3), MbC(Trim(b3), Trim(a1)))
  Do While MBJC(Trim(ja), Trim(b3)) >= 0
  ja = MPC(Trim(ja), Trim(b3))
  s5 = s5 + 1
  Loop
  a1 = MPC1(Trim(a1), Trim(s5))
  If ja = 0 Then
  Text3 = a1
  Else
  Text3 = a1 & "/" & ja
  End If
  End Sub

  Private Sub Command2_Click()
  Text1 = ""
  Text2 = ""
  Text3 = ""

  End Sub
  Private Function mbc2(sa As String, sb As String, sd As String) As String 'chengfa jingdu
  Dim ja

  If Trim(sa) = 0 Or Trim(sb) = 0 Then
  mbc2 = 0
  Else

  ja = MbC(Trim(sa), Trim(sb))
  If Val(Len(ja)) > Val(sd) Then
  jb = Left(ja, Val(Len(ja)) - Val(sd))
  mbc2 = jb
  Else
  mbc2 = 0
  End If

  End If

  End Function

Private Function qdhz0(sa As String) As String
  a = sa
  Do While Right(a, 1) = "0"
  a = Left(a, Len(a) - 1)
  Loop
  If a = "" Then
  a = 0
  Else
  a = a
  End If
  qdhz0 = a
  End Function

  Private Function qdqd0(sa As String) As String
  a = sa
  Do While Left(a, 1) = "0"
  a = Mid(a, 2)
  Loop
  If a = "" Then
  a = 0
  Else
  a = a
  End If
  qdqd0 = a
  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

  Private Function ydxsd(sa As String, sd As String) As String
  If Len(sa) = 1 And Val(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

      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

  Public Function MBJC(D1 As String, D2 As String) As String ';bijiao
  If Len(D1) <= 10 And Len(D2) <= 10 Then
  If Val(D1) > Val(D2) Then
  MBJC = 1
  Else
  If Val(D1) = Val(D2) Then
  MBJC = 0
  Else
  MBJC = -1
  End If
  End If
  Else

  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 If
  End Function

ysr · 发表于 2021-3-2 01:24

哈哈哈！这回蒙对了！太激动了！下面是结果和程序代码：
输入：Text1=20403000,结果： 9+0i  4.12132034355965+-6.12132034355964i  -2+-3i  -0.121320343559644+1.87867965644035i  3+0i  -0.121320343559638+-1.87867965644036i  -2+3i  4.12132034355963+6.12132034355965i.

代码如下：

Private Sub Command1_Click() '蝶形运算程序
Dim xr() As Double, a As String
a = Trim(Text1)
ReDim xr(0 To Len(a) - 1)
For i1 = 0 To Len(a) - 1
xr(i1) = Mid(a, i1 + 1, 1)
  Next
Dim l As Long, le As Long, le1 As Long, n As Long, r As Long, p As Long, q As Long, m As Byte
Dim wr As Double, w1 As Double, wlr As Double, wl1 As Double, tr As Double, t1 As Double
Dim pi As Double, t As Double
Dim xi()
n = Len(a) '求数组大小，其值必须是2的幂
m = 0
l = 2
pi = 3.14159265358979
Do
l = l + l
m = m + 1
Loop Until l > n
n = l / 2
ReDim xi(n - 1)

l = 1
Do
  le = 2 ^ l
  le1 = le / 2
  Print l
  r = 0
Do
  p = r
  Do
q = p + le1

tr = xr(q) * Cos((-2 * pi / 2 ^ l) * r)
ti = xr(q) * Sin((-2 * pi / 2 ^ l) * r)

xr(q) = xr(p) - tr
xi(q) = xi(p) - ti
xr(p) = xr(p) + tr
xi(p) = xi(p) + ti
Print p, q

Print xr(p); xi(p); r, xr(q); xi(q); r

p = p + le
Loop Until p > n - 2

r = r + 1
Loop Until r > le1 - 1
l = l + 1
Loop Until l > m

For i = 0 To n - 1 '仅输出模
Print xr(i), xi(i)
Text2 = Text2 & "  " & xr(i) & "+" & xi(i) & "i"
Next

End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
End Sub

明天再说吧！

		自动登录	找回密码
密码			注册