Const MaxIter = 100
Const Eps = 0.00001
Dim a As Double, b As Double, c As Double, d As Double
Private Sub Command1_Click()
Dim Root As Double, Iter As Long, xL As Double, xR As Double
a = Val(Text1): b = Val(Text2)
c = Val(Text3): d = Val(Text4)
xL = Val(Text5): xR = Val(Text6)
If CheckParameters(a, b, c, xL, xR) = False Then Exit Sub
Root = ModBisect(xL, xR, Iter)
MsgBox "方程的根=" & Root & vbCrLf & "叠代次數=" & Iter
End Sub
Private Function CheckParameters(a#, b#, c#, xL#, xR#) As Boolean
CheckParameters = True
If a = 0 And b = 0 And c = 0 Then
MsgBox "方程參數輸入有問題,請重新輸入!", vbCritical, "警告..."
CheckParameters = False
End If
If fun(xL) * fun(xR) > 0 Then
MsgBox "兩根的函數值必須異號!", vbCritical, "警告..."
CheckParameters = False
End If
End Function
Private Function fun(x) As Double
Dim fval As Double
fval = a * x ^ 3 + b * x ^ 2 + c * x + d
fun = fval
End Function
Private Function ModBisect(a As Double, b As Double, Iter As Long) As Double
Dim c As Double, fval As Double
Do
Iter = Iter + 1
c = (a + b) * 0.5
fval = fun(c)
If Abs(fval) <= Eps Then
ModBisect = c
Exit Function
End If
If fval * fun(a) < 0 Then
b = c
Else
a = c
End If
Loop While (Iter <= MaxIter)
ModBisect = c
MsgBox "超出最大叠代次數!", vbCritical, "警告..."
End Function