📄 form1.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "msflxgrd.ocx"
Begin VB.Form Form1
Caption = "曲线拟合"
ClientHeight = 8520
ClientLeft = 225
ClientTop = 825
ClientWidth = 11670
LinkTopic = "Form1"
ScaleHeight = 8520
ScaleWidth = 11670
StartUpPosition = 3 'Windows Default
Begin VB.TextBox Text1
Height = 1335
Left = 4920
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 7
Top = 6960
Width = 6255
End
Begin VB.ComboBox Combo1
Enabled = 0 'False
Height = 315
Left = 3120
TabIndex = 6
Text = "3"
Top = 7560
Width = 855
End
Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1
Height = 5895
Left = 240
TabIndex = 5
Top = 480
Width = 4275
_ExtentX = 7541
_ExtentY = 10398
_Version = 393216
Rows = 25
Cols = 3
FormatString = "^记录数|^ X|^ Y"
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 3000
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CheckBox Check5
Caption = "显示拟合点"
Enabled = 0 'False
Height = 615
Left = 480
TabIndex = 4
Top = 7800
Width = 1935
End
Begin VB.CheckBox Check2
Caption = "显示R"
Enabled = 0 'False
Height = 495
Left = 480
TabIndex = 3
Top = 7200
Width = 1335
End
Begin VB.CheckBox Check1
Caption = "显示公式"
Enabled = 0 'False
Height = 495
Left = 480
TabIndex = 2
Top = 6600
Width = 1335
End
Begin VB.PictureBox Picture1
Height = 6495
Left = 4920
ScaleHeight = 6435
ScaleWidth = 6435
TabIndex = 0
Top = 120
Width = 6495
End
Begin VB.Label Label2
Caption = "多项式拟合次数"
Enabled = 0 'False
Height = 495
Left = 2520
TabIndex = 8
Top = 6960
Width = 1575
End
Begin VB.Label Label1
Caption = "源数据"
Height = 375
Left = 240
TabIndex = 1
Top = 120
Width = 1455
End
Begin VB.Menu cal1
Caption = "文件"
Begin VB.Menu new
Caption = "新建"
End
Begin VB.Menu op
Caption = "打开"
End
Begin VB.Menu sav
Caption = "保存"
End
Begin VB.Menu ex
Caption = "退出"
End
End
Begin VB.Menu typ
Caption = "拟合类型"
Begin VB.Menu typ1
Caption = "线性"
End
Begin VB.Menu typ2
Caption = "对数"
End
Begin VB.Menu typ3
Caption = "多项式"
End
Begin VB.Menu typ4
Caption = "乘幂"
End
Begin VB.Menu typ5
Caption = "指数"
End
Begin VB.Menu sanci
Caption = "三次样条拟合"
End
End
Begin VB.Menu gph
Caption = "绘图"
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim x() As Double, y() As Double, X1() As Double, Y1() As Double, y2() As Double
Dim A(20, 20) As Double, M As Integer, B() As Double '最多取20次的拟合
Dim N As Integer, I As Integer, J As Integer
Dim xiaoA() As Double, xiaoB() As Double
Dim Xmin As Double, Xmax As Double
Dim Ymin As Double, Ymax As Double
Dim Xo As Double, Yo As Double, Ya As Double, z1 As Double, z2 As Double, z3 As Double, R As Double
Private Sub Check1_Click()
Dim Str As String: Str = "y="
If sg = 1 Then
Str = Str & xiaoA(2) & "x+" & xiaoA(1)
ElseIf sg = 2 Then
Str = Str & xiaoA(2) & "Ln x+" & xiaoA(1)
ElseIf sg = 3 Then
For I = 1 To M '写方程
If I < M Then
Str = Str & xiaoA(I) & "x^" & I - 1 & "+"
Else
Str = Str & xiaoA(I) & "x^" & I - 1
End If
Next I
ElseIf sg = 4 Then
Str = Str & xiaoB(1) & "e^" & "(" & xiaoA(2) & "*x)"
Else
Str = Str & xiaoB(1) & "*x^" & xiaoA(2)
End If
Text1.Text = Text1.Text & vbCrLf & "曲线方程:" & vbCrLf & Str
End Sub
Private Sub Check4_Click()
End Sub
Private Sub Check2_Click()
ReDim y2(N)
For I = 1 To N
Select Case sg
Case 1
y2(I) = xiaoA(1) + xiaoA(2) * x(I)
Case 2
y2(I) = xiaoA(1) + xiaoA(2) * Log(x(I))
Case 3
Dim Ysum As Double
y2(I) = 0
For J = 1 To M
y2(I) = y2(I) + xiaoA(J) * x(I) ^ (J - 1)
Next J
Case 4
ReDim xiaoB(2)
xiaoB(1) = Exp(xiaoA(1))
xiaoB(2) = xiaoA(2)
y2(I) = xiaoB(1) * x(I) ^ xiaoB(2)
Case 5
ReDim xiaoB(2)
xiaoB(1) = Exp(xiaoA(1))
xiaoB(2) = xiaoA(2)
y2(I) = xiaoB(1) * Exp(xiaoB(2) * x(I))
End Select
Next I
Ya = 0
For I = 1 To N
Ya = Ya + y(I)
Next I
Ya = Ya / N
z1 = 0
z2 = 0
z3 = 0
For I = 1 To N
z1 = z1 + (y(I) - Ya) * (y2(I) - Ya)
z2 = z2 + (y(I) - Ya) ^ 2
z3 = z3 + (y2(I) - Ya) ^ 2
Next I
R = z1 ^ 2 / (z2 * z3)
Text1.Text = Text1.Text & vbCrLf & "R^2=" & R & vbCrLf
End Sub
Private Sub Check5_Click()
Picture1.DrawWidth = 5
For I = 1 To N
Select Case sg
Case 1
Yo = xiaoA(1) + xiaoA(2) * x(I)
Case 2
Yo = xiaoA(1) + xiaoA(2) * Log(x(I))
Case 3
Dim Ysum As Double
Yo = 0
For J = 1 To M
Yo = Yo + xiaoA(J) * x(I) ^ (J - 1)
Next J
Case 4
ReDim xiaoB(2)
xiaoB(1) = Exp(xiaoA(1))
xiaoB(2) = xiaoA(2)
Yo = xiaoB(1) * x(I) ^ xiaoB(2)
Case 5
ReDim xiaoB(2)
xiaoB(1) = Exp(xiaoA(1))
xiaoB(2) = xiaoA(2)
Yo = xiaoB(1) * Exp(xiaoB(2) * x(I))
End Select
Picture1.PSet (x(I), Yo), vbBlue
Next I
End Sub
Private Sub Form_Load()
For I = 0 To 2
MSFlexGrid1.ColAlignment(I) = 4
Next I
For I = 1 To 20
MSFlexGrid1.TextMatrix(I, 0) = I
Next I
End Sub
Private Sub ZuoDian(x() As Double, y() As Double)
Dim XL As Double
Dim YL As Double
N = UBound(x): Picture1.Cls
Xmin = x(1): Xmax = x(1): Xo = x(1): Yo = y(1)
Ymin = y(1): Ymax = y(1)
For I = 1 To N
If Xmin > x(I) Then
Xmin = x(I)
Xo = Xmin: Yo = y(I) '后面画曲线时用到。
End If
If Xmax < x(I) Then Xmax = x(I)
If Ymin > y(I) Then Ymin = y(I)
If Ymax < y(I) Then Ymax = y(I)
Next I
Select Case sg
Case 1
Yo = xiaoA(1) + xiaoA(2) * Xmin
If Yo < Ymin Then
Ymin = Yo
End If
Yo = xiaoA(1) + xiaoA(2) * Xmax
If Yo > Ymax Then
Ymax = Yo
End If
Case 2
Yo = xiaoA(1) + xiaoA(2) * Log(Xmin)
If Yo < Ymin Then
Ymin = Yo
End If
Yo = xiaoA(1) + xiaoA(2) * Log(Xmax)
If Yo > Ymax Then
Ymax = Yo
End If
Case 3
Dim Ysum As Double
Yo = 0
For J = 1 To M
Yo = Yo + xiaoA(J) * Xmin ^ (J - 1)
Next J
If Yo < Ymin Then
Ymin = Yo
End If
Yo = 0
For J = 1 To M
Yo = Yo + xiaoA(J) * Xmax ^ (J - 1)
Next J
If Yo > Ymax Then
Ymax = Yo
End If
Case 4
ReDim xiaoB(2)
xiaoB(1) = Exp(xiaoA(1))
xiaoB(2) = xiaoA(2)
Yo = xiaoB(1) * Xmin ^ xiaoB(2)
If Yo < Ymin Then
Ymin = Yo
End If
Yo = xiaoB(1) * Xmax ^ xiaoB(2)
If Yo > Ymax Then
Ymax = Yo
End If
Case 5
ReDim xiaoB(2)
xiaoB(1) = Exp(xiaoA(1))
xiaoB(2) = xiaoA(2)
Yo = xiaoB(1) * Exp(xiaoB(2) * Xmin)
If Yo < Ymin Then
Ymin = Yo
End If
Yo = xiaoB(1) * Exp(xiaoB(2) * Xmax)
If Yo > Ymax Then
Ymax = Yo
End If
End Select
XL = Xmax - Xmin: YL = Ymax - Ymin
Picture1.Scale (Xmin - XL / 10, Ymax + YL / 10)-(Xmax + XL / 10, Ymin - YL / 10)
Picture1.DrawWidth = 5
For I = 1 To N
Picture1.PSet (x(I), y(I)), vbRed
Next I
Picture1.DrawWidth = 1
Picture1.Line (Xmin, Ymin)-(Xmax, Ymax), vbBlack, B
Dim qi As Integer, jian As Integer
qi = Int(Xmin + 1)
jian = Fix((Xmax - Xmin) / 5)
For I = 1 To 4
Picture1.Line (qi + I * jian, Ymin)-(qi + I * jian, Ymin + (Ymax - Ymin) / 40), vbBlack, B
Next I
qi = Int(Ymin + 1)
jian = Fix((Ymax - Ymin) / 5)
For I = 1 To 4
Picture1.Line (Xmin, qi + I * jian)-(Xmin + (Xmax - Xmin) / 40, qi + I * jian), vbBlack, B
Next I 'Picture1.Refresh
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -