'求表达式的值
Function erresult(ByVal expression As String, ByVal x As String) As Single
Dim tmpStr As String
tmpStr = Replace(UCase(expression), "LN", "Log")
tmpStr = Replace(tmpStr, "X", x)
Dim OBJ As Object
Set OBJ = CreateObject("MSScriptControl.ScriptControl")
OBJ.Language = "vbscript"
erresult = OBJ.Eval(tmpStr)
Set OBJ = Nothing
End Function
'小数点后保留四位
Function yxw(ByVal b As Single) As Single
yxw = CSng(Fix(b * 10000) / 10000)
End Function
Public Function fmin(ByVal f As String, ByVal a1 As String, ByVal a2 As String, ByVal a3 As String) As String
Const e = 0.01
Dim a4 As String
Dim c1, c2 As Single
Dim f1, f2, f3, f4 As Single
Dim flag As Integer
f1 = erresult(f, a1)
f2 = erresult(f, a2)
f3 = erresult(f, a3)
Do
If a2 = a3 Then
a3 = a3 + 1 '保证分母不为零,如果求得结果与书值不同.修改此处
End If
If a3 = a1 Then
a3 = a3 + 1 '保证分母不为零,如果求得结果与书值不同.修改此处
End If
If f3 = f1 Then
f3 = f3 + 1
End If
c1 = (f3 - f1) / (CSng(a3) - CSng(a1))
c2 = ((f2 - f1) / (CSng(a2) - CSng(a1)) - c1) / (CSng(a2) - CSng(a3))
If c2 = 0 Then
flag = 1
Exit Do
End If
a4 = 0.5 * (CSng(a1) + CSng(a3) - c1 / c2)
If (CSng(a4) - CSng(a1)) * (CSng(a3) - CSng(a4)) > 0 Then
a4 = CStr(a4)
f4 = erresult(f, a4)
Else
flag = 1
Exit Do
End If
If Abs((f2 - f4) / f2) > e Then
If (CSng(a4) - CSng(a2)) * (CSng(a4) - CSng(a1)) > 0 Then
If f2 > f4 Then
a1 = CStr(a2)
f1 = f2
a2 = CStr(a4)
f2 = f4
Else
a3 = CStr(a4)
f3 = f4
End If
Else
If f2 > f4 Then
a2 = CStr(a4)
f2 = f4
a3 = CStr(a2)
f3 = f2
Else
f1 = f4
a1 = CStr(a4)
End If
End If
Else
f44 = f4
a44 = CSng(a4)
f22 = f2
a22 = CSng(a2)
Exit Do
End If
Loop
If f44 > f22 Then '这儿怎么和条件相反合适p67有空查查
fmin = yxw(a44)
Else
flag = 1
GoTo ee
End If
ee: If flag = 1 Then
fmin = yxw(a22)
End If
End Function
'测试函数8*x^3-2*x^2-7*x+3
'区间[0 1 2]
'精度0.01如果不对修改精度
'得最小值x=0.6209 f=-0.204
Private Sub Command1_Click()
Print fmin("8*x^3-2*x^2-7*x+3", 0, 1, 2)
End Sub
Private Sub Form_Load()
Form1.WindowState = 2
End Sub