代码如下:Option Explicit
Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long Private Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function Function FunVal(ByVal f As String, ByVal x As Double) As Double
f = Replace(f, "x", "(" & Str(x) & ")")
ExecuteLine "dim f as double"
ExecuteLine "f= " & f
ExecuteLine "clipboard.settext f"
FunVal = Clipboard.GetText
End Function Private Sub Command1_Click()
Dim a As Double, b As Double, e As Double
Dim a1 As Double, a2 As Double
Dim f1 As Double, f2 As Double
Dim fx As String, iCount As Integer
fx = Text1 '表达式
a = Val(Text2): b = Val(Text3) '搜索区间
e = Val(Text4) '搜索精度
a1 = b - 0.618 * (b - a)
a2 = a + 0.618 * (b - a)
f1 = FunVal(fx, Str(a1))
f2 = FunVal(fx, Str(a2))
While b - a > e
iCount = iCount + 1
If f1 >= f2 Then
a = a1: a1 = a2: f1 = f2
a2 = a + 0.618 * (b - a)
f2 = FunVal(fx, a2)
Else
b = a2: a2 = a1: f2 = f1
a1 = b - 0.618 * (b - a)
f1 = FunVal(fx, a1)
End If
Wend
Text5 = "求优结果:" + vbCrLf
Text5 = Text5 + "函数在x=" + Format((a + b) / 2, "0.#####") + "处取得极值,"
Text5 = Text5 + "极值为:" + Format(FunVal(fx, (a + b) / 2), "0.#####") + vbCrLf
Text5 = Text5 + "叠代次数:" + Str(iCount)
End Sub Private Sub Form_Load()
Dim sTitle As String, i As Integer
Show
sTitle = "黄金分割法一维求优"
Me.Font.Size = 24
Me.Font.Name = "楷体_GB2312"
Randomize
For i = 1 To 10
Me.CurrentX = (Me.ScaleWidth - Me.TextWidth(sTitle)) / 2 + 0.5 * i
Me.CurrentY = 10 + i * 0.4
Me.ForeColor = QBColor(Int(16 * Rnd()))
Me.Print sTitle
Next i
End Sub Private Sub Text1_DblClick()
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub
Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long Private Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function Function FunVal(ByVal f As String, ByVal x As Double) As Double
f = Replace(f, "x", "(" & Str(x) & ")")
ExecuteLine "dim f as double"
ExecuteLine "f= " & f
ExecuteLine "clipboard.settext f"
FunVal = Clipboard.GetText
End Function Private Sub Command1_Click()
Dim a As Double, b As Double, e As Double
Dim a1 As Double, a2 As Double
Dim f1 As Double, f2 As Double
Dim fx As String, iCount As Integer
fx = Text1 '表达式
a = Val(Text2): b = Val(Text3) '搜索区间
e = Val(Text4) '搜索精度
a1 = b - 0.618 * (b - a)
a2 = a + 0.618 * (b - a)
f1 = FunVal(fx, Str(a1))
f2 = FunVal(fx, Str(a2))
While b - a > e
iCount = iCount + 1
If f1 >= f2 Then
a = a1: a1 = a2: f1 = f2
a2 = a + 0.618 * (b - a)
f2 = FunVal(fx, a2)
Else
b = a2: a2 = a1: f2 = f1
a1 = b - 0.618 * (b - a)
f1 = FunVal(fx, a1)
End If
Wend
Text5 = "求优结果:" + vbCrLf
Text5 = Text5 + "函数在x=" + Format((a + b) / 2, "0.#####") + "处取得极值,"
Text5 = Text5 + "极值为:" + Format(FunVal(fx, (a + b) / 2), "0.#####") + vbCrLf
Text5 = Text5 + "叠代次数:" + Str(iCount)
End Sub Private Sub Form_Load()
Dim sTitle As String, i As Integer
Show
sTitle = "黄金分割法一维求优"
Me.Font.Size = 24
Me.Font.Name = "楷体_GB2312"
Randomize
For i = 1 To 10
Me.CurrentX = (Me.ScaleWidth - Me.TextWidth(sTitle)) / 2 + 0.5 * i
Me.CurrentY = 10 + i * 0.4
Me.ForeColor = QBColor(Int(16 * Rnd()))
Me.Print sTitle
Next i
End Sub Private Sub Text1_DblClick()
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub