ht.frm

方程求根程序。根据图像用半区间搜索法

VERSION 5.00
Begin VB.Form Form1 
   AutoRedraw      =   -1  'True
   Caption         =   "方程求根程序－－－徐永群设计                  版权所有  盗刻必究"
   ClientHeight    =   9975
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   15240
   Icon            =   "ht.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   9975
   ScaleWidth      =   15240
   StartUpPosition =   3  '窗口缺省
   WindowState     =   2  'Maximized
   Begin VB.CommandButton Command3 
      Caption         =   "结束"
      Height          =   495
      Left            =   13440
      TabIndex        =   8
      Top             =   3240
      Width           =   1455
   End
   Begin VB.CommandButton Command2 
      Caption         =   "求根"
      Height          =   495
      Left            =   13440
      TabIndex        =   7
      Top             =   2160
      Width           =   1455
   End
   Begin VB.CommandButton Command1 
      Caption         =   "找根的范围"
      Height          =   615
      Left            =   13440
      TabIndex        =   4
      Top             =   960
      Width           =   1455
   End
   Begin VB.TextBox Text2 
      Height          =   270
      Left            =   4200
      TabIndex        =   3
      Text            =   "2"
      Top             =   240
      Width           =   1455
   End
   Begin VB.TextBox Text1 
      Height          =   270
      Left            =   2280
      TabIndex        =   1
      Text            =   "1"
      Top             =   240
      Width           =   1335
   End
   Begin VB.Label Label4 
      Height          =   255
      Left            =   6840
      TabIndex        =   6
      Top             =   240
      Width           =   3735
   End
   Begin VB.Label Label3 
      Caption         =   "方程的根："
      Height          =   255
      Left            =   5760
      TabIndex        =   5
      Top             =   240
      Width           =   1215
   End
   Begin VB.Label Label2 
      Caption         =   "～"
      Height          =   255
      Left            =   3840
      TabIndex        =   2
      Top             =   240
      Width           =   255
   End
   Begin VB.Label Label1 
      Caption         =   "根x的范围："
      Height          =   255
      Left            =   1080
      TabIndex        =   0
      Top             =   240
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim X(1000), Y(1000)
Dim xd As Single, xx As Single, yd As Single, yx As Single, b0 As Single
Dim dx As Single, dy As Single, m As Integer, n As Integer, p As Integer

Private Sub Command1_Click()
Line (0, 600)-(14000, 11000), &H8000000F, BF
Line (1000, 1000)-(13000, 10000), , B
For i = 1 To 9
Line (1000 + 1200 * i, 10000)-(1000 + 1200 * i, 9950)
Line (1000, 1000 + 900 * i)-(1050, 1000 + 900 * i)
Next i

'------ 函数部分 ---------
m = 1000
detx = (Val(Text2.Text) - Val(Text1.Text)) / 1000
For i = 0 To m
X(i) = Val(Text1.Text) + i * detx
Y(i) = Fx(X(i))
Next i

tt = 0
For i = 1 To m - 1
If Y(i) * Y(i + 1) < 0 Then Y0 = Y(i): tt = 1: Exit For
Next i
'------ 找极值部分 ---------
xd = X(0): xx = X(0): yd = Y(0): yx = Y(0)
For i = 0 To m
If X(i) > xd Then xd = X(i)
If X(i) < xx Then xx = X(i)
If Y(i) > yd Then yd = Y(i)
If Y(i) < yx Then yx = Y(i)
Next i
dx = xd - xx: dy = yd - yx

'------ 绘图部分 ---------
X1 = 1000 + 12000 * (X(0) - xx) / dx
Y1 = 10000 - 9000 * (Y(0) - yx) / dy
Line (X1, Y1)-(X1, Y1)
For i = 0 To m
X1 = 1000 + 12000 * (X(i) - xx) / dx
Y1 = 10000 - 9000 * (Y(i) - yx) / dy
Line -(X1, Y1), RGB(255, 0, 0)
Next i

If tt = 1 Then
Y1 = 10000 - 9000 * (Y0 - yx) / dy
For i = 1 To 119
  Line (1000 + i * 100, Y1)-(1000 + i * 100 + 50, Y1), RGB(0, 0, 255)
Next i
PSet (3000, 650), &H8000000F: Print "方程在此x值范围内有解"
End If

'------ 标坐标程序 ---------
PSet (900, 10200), &H8000000F: Print xx
PSet (6800, 10200), &H8000000F: Print xx + dx / 2
PSet (12700, 10200), &H8000000F: Print xd
PSet (10, 9900), &H8000000F: Print yx
PSet (10, 5450), &H8000000F: Print yx + dy / 2
PSet (10, 1000), &H8000000F: Print yd
PSet (10000, 10300), &H8000000F: Print "X"
PSet (500, 2000), &H8000000F: Print "Y"

End Sub
Function Fx(t)
'－－方程－－－－
   Fx = t * t * t - 10 * t - 1000
'－－方程－－－－
End Function

Private Sub Command2_Click()
X1 = Val(Text1.Text)
X2 = Val(Text2.Text)
Time1 = 0
30 F1 = Fx(X1)
40 F2 = Fx(X2)
50 xm = (X1 + X2) / 2
fm = Fx(xm)
If fm = 0 Then Xr = xm: GoTo ee
Time1 = Time1 + 1
If Time1 >= 10000 Then Label4.Caption = "在该范围内无根！": GoTo ee1
If F1 * fm >= 0 Then X1 = xm: F1 = fm: GoTo 50
If Abs(X1 - xm) / (Abs(X1) + Abs(xm)) > 0.000001 Then X2 = xm: F2 = fm: GoTo 50
Xr = (X1 + xm) / 2
ee: Label4.Caption = Xr
ee1: End Sub

Private Sub Command3_Click()
End
End Sub

Private Sub Form_Activate()
Line (1000, 1000)-(13000, 10000), , B
For i = 1 To 9
Line (1000 + 1200 * i, 10000)-(1000 + 1200 * i, 9950)
Line (1000, 1000 + 900 * i)-(1050, 1000 + 900 * i)
Next i
End Sub