📄 form1.frm
字号:
Left = 7065
TabIndex = 13
Top = 8640
Width = 180
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "30"
Height = 180
Index = 2
Left = 6075
TabIndex = 12
Top = 8640
Width = 180
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "20"
Height = 180
Index = 1
Left = 4950
TabIndex = 11
Top = 8640
Width = 180
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "10"
Height = 180
Index = 0
Left = 3960
TabIndex = 10
Top = 8640
Width = 180
End
Begin VB.Label Label3
AutoSize = -1 'True
BeginProperty Font
Name = "宋体"
Size = 15
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 3360
TabIndex = 9
Top = 480
Width = 165
End
Begin VB.Label Label2
Caption = "Y:"
BeginProperty Font
Name = "宋体"
Size = 15
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 360
TabIndex = 3
Top = 5400
Width = 375
End
Begin VB.Label Label1
Caption = "X:"
BeginProperty Font
Name = "宋体"
Size = 15
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 360
TabIndex = 2
Top = 4800
Width = 375
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim t() As Double '动态数组,容量可以变,用来盛放横坐标数据
Dim s() As Double '动态数组,容量可以变,用来盛放纵坐标数据
Dim a As Integer '窗体变量声明, a用来存放数组上限, 在过程中修改, 以实现动态数组
Dim yy1 As Double 'yy1,yy2窗体变量,分别存放最终拟合直线上两个点的纵坐标
Dim yy2 As Double
Private Sub Command1_Click() '增加数据按钮
Dim c As Double '局部变量c,d声明
Dim d As Double
If txtx.Text <> "" And txty.Text <> "" Then
c = 3000 + 100 * CDbl(txtx.Text) '(c,d)为点在坐标系上的位置,坐标原点是(3000,9000)
d = 9000 - 100 * CDbl(txty.Text)
a = a + 1 '添加数据,盛放数据的数组增加一个容量
ReDim Preserve t(a) '重定义数组
t(a) = CDbl(txtx.Text)
ReDim Preserve s(a)
s(a) = CDbl(txty.Text)
List1.AddItem (a & "." & "(" & t(a) & "," & s(a) & ")") '增加的数据放入表单显示
Form1.FillColor = vbRed '红色填充,窗体填充改为红色
Circle (c, d), 20, vbRed '以(c,d)为圆心,20为半径,画一个红色的圆,由于半径小,又是实心圆,在坐标系上将是一个"点",既将添加的点在坐标系中显示出来
txtx.Text = "" '清空两个数据输入框
txty.Text = ""
Else
MsgBox "请输入相关数据" '如果数据输入框为空,提示输入数据
End If
End Sub '数据添加过程结束
Private Sub Command2_Click() '清空数据按钮
For i = 1 To a '循环清楚坐标系上的点
Form1.FillColor = BackColor '填充色改为背景色,以达到擦去点的目的
Circle (3000 + 100 * t(i), 9000 - 100 * s(i)), 20, BackColor '以背景色画圆,清楚点(t(i),s(i))
Next
a = 0 '初始化数组,数组上限调整为零
ReDim t(a) '初始化数组
ReDim s(a)
List1.Clear '清空显示数据的数组
Timer1.Enabled = False
Randomize
Line (3000, 9000 - 100 * yy1)-(11000, 9000 - 100 * yy2), BackColor '清楚坐标系中的拟合线
Label3.Caption = ""
For i = 1 To 16 '重画网格
Line (3000 + 500 * i, 9000)-(3000 + 500 * i, 1000), &H8000000C
Line (3000, 9000 - 500 * i)-(11000, 9000 - 500 * i), &H8000000C
Next
Line (3000, 700)-(3000, 9000) '重画坐标轴
Line (3000, 9000)-(11300, 9000)
End Sub '数据清空过程结束
Private Sub Command3_Click() '数据删除按钮的单击事件
Dim f As Integer
If a <> 0 Then '如果有数据,既数组上限a>0
f = List1.ListIndex + 1 '被选中的数据的序列号
Form1.FillColor = BackColor '窗体填充色改为窗体背景色
Circle (3000 + 100 * t(f), 9000 - 100 * s(f)), 20, BackColor '以填充色画圆实现点(3000 + 100 * t(f), 9000 - 100 * s(f))在坐标系上的清楚
For i = f To a - 1
t(i) = t(i + 1) '从f开始对数组数据进行调整
s(i) = s(i + 1)
Next
a = a - 1 '删除一条数据,数组上限减1
ReDim Preserve t(a) '重定义数组
ReDim Preserve s(a)
List1.Clear '清空列表
For i = 1 To a '用数组重新给列表添加项
If a > 9 Then
List1.AddItem (i & ". " & "(" & t(i) & "," & s(i) & ")")
Else
List1.AddItem (i & "." & "(" & t(i) & "," & s(i) & ")")
End If
Next
Else
MsgBox "你还没有添加数据你删谁呀" 'a=0,提示输入数据
End If
End Sub '数据删除过程结束
Private Sub Command4_Click() '开始拟合按钮的单击事件
If a <> 1 And a <> 0 Then '判断至少由两个点被输入
If a = 2 And t(1) = t(2) Then
MsgBox "斜率过大,超出double范围,请更改数据"
Else
For i = 1 To a '算∑
hx = hx + t(i) '∑X 用hx
hy = hy + s(i) '∑Y 用hy
hx2 = hx2 + t(i) * t(i) '∑X*X用hx2
hy2 = hy2 + s(i) * t(i) '∑Y*Y用hy2
hxy = hxy + s(i) * t(i) '∑X*Y用hxy
Next
px = hx / a 'X平均值px
py = hy / a 'Y平均值py
lxx = hx2 - a * px * px 'Lxx
lxy = hxy - a * px * py 'Lxy
p = lxy / lxx '拟合直线斜率p
q = py - p * px '拟合直线截距q
yy1 = q 'x=0 对应的y值,既点(0 ,yy1)
yy2 = q + p * 80 'x=80对应的y值,既点(80,yy2)
If q <> 0 Then '把拟合直线方程用标签在窗体上显示出来
If p > 0 Then
Label3.Caption = "y = " & q & " + " & p & "x"
ElseIf p = 1 Then
Label3.Caption = "y = " & q & " + " & "x"
Else
Label3.Caption = "y = " & q & " + " & "(" & p & ")" & "x"
End If
Else
If p <> 1 Then
Label3.Caption = "y = " & p & "x"
Else
Label3.Caption = "y = " & "x"
End If
End If
Timer1.Enabled = True '激活timer1的timer事件
End If
Else
MsgBox "我靠,你输入的数据也太少了吧,就这也想拟合出直线来呀,做梦吧" '输入数据少于两组,提示输入
End If
End Sub '拟合按钮单击事件结束
Private Sub Command5_Click() '随即获取散点过程
For i = 1 To 20 '获取20个散点
Randomize '获取随机数种子
a = a + 1 '数组上限加1,以存放获取的一组数据
r1 = 80 * Rnd '获取两个0到80之间的随机数
r2 = 80 * Rnd
cc = 3000 + 100 * CDbl(r1) '获取一组随机数对应的坐标,Cdbl()函数用来将随机数,转换为double类型
dd = 9000 - 100 * CDbl(r2)
ReDim Preserve t(a) '重定义数组
t(a) = CDbl(r1) '对数组新添加的一个容量赋值,
ReDim Preserve s(a)
s(a) = CDbl(r2)
mm = Left(CStr(t(a)), 5) '将随即获取的随机数转换为字符串,取其左边的五个字符显示
nn = Left(CStr(s(a)), 5)
If a < 10 Then '新添加的点在list1中显示出来
List1.AddItem (a & ". " & "(" & mm & "," & nn & ")")
Else
List1.AddItem (a & "." & "(" & mm & "," & nn & ")")
End If
Form1.FillColor = vbRed '窗体填充色变为红色
Circle (cc, dd), 20, vbRed '画圆
Next
End Sub '随机散点获取过程结束
Private Sub Command6_Click() '重载窗体按钮单击事件
a = 0 '数组上限设为零
ReDim t(a) '重定义数组
ReDim s(a)
Label3.Caption = "" '去掉拟合直线方程
Timer1.Enabled = False '使timer1的timer事件无效
List1.Clear '清空列表
Line (0, 0)-(14000, 10000), BackColor, BF '以背景色画一个窗体尺寸的矩形,清楚窗体中的图形
Line (3000, 700)-(3000, 9000) '重画坐标轴
Line (3000, 9000)-(11300, 9000)
For i = 1 To 16 '重画网格
Line (3000 + 500 * i, 9000)-(3000 + 500 * i, 1000), &H8000000C
Line (3000, 9000 - 500 * i)-(11000, 9000 - 500 * i), &H8000000C
Next
For i = 0 To 80 '重刻标度
If i Mod 10 = 0 Then
Line (3000, 1000 + 100 * i)-(3180, 1000 + 100 * i), RGB(0, 0, 255)
Line (3000 + 100 * i, 9000)-(3000 + 100 * i, 8820), RGB(0, 0, 255)
ElseIf i Mod 5 = 0 Then
Line (3000, 1000 + 100 * i)-(3120, 1000 + 100 * i), RGB(0, 0, 255)
Line (3000 + 100 * i, 9000)-(3000 + 100 * i, 8880), RGB(0, 0, 255)
Else
Line (3000, 1000 + 100 * i)-(3080, 1000 + 100 * i), RGB(0, 0, 255)
Line (3000 + 100 * i, 9000)-(3000 + 100 * i, 8920), RGB(0, 0, 255)
End If
Next
End Sub '窗体重载过程结束
Private Sub Command7_Click() '窗体退出事件
Unload Me
End Sub
Private Sub Form_Activate() '窗体激活事件
a = 0
Width = 14000
Height = 10000
Line (3000, 700)-(3000, 9000) '画坐标轴,圆心坐标(3000,9000)
Line (3000, 9000)-(11300, 9000)
For i = 1 To 16 '画网格
Line (3000 + 500 * i, 9000)-(3000 + 500 * i, 1000), &H8000000C
Line (3000, 9000 - 500 * i)-(11000, 9000 - 500 * i), &H8000000C
Next
For i = 0 To 80 '刻标度
If i Mod 10 = 0 Then
Line (3000, 1000 + 100 * i)-(3180, 1000 + 100 * i), RGB(0, 0, 255)
Line (3000 + 100 * i, 9000)-(3000 + 100 * i, 8820), RGB(0, 0, 255)
ElseIf i Mod 5 = 0 Then
Line (3000, 1000 + 100 * i)-(3120, 1000 + 100 * i), RGB(0, 0, 255)
Line (3000 + 100 * i, 9000)-(3000 + 100 * i, 8880), RGB(0, 0, 255)
Else
Line (3000, 1000 + 100 * i)-(3080, 1000 + 100 * i), RGB(0, 0, 255)
Line (3000 + 100 * i, 9000)-(3000 + 100 * i, 8920), RGB(0, 0, 255)
End If
Next
End Sub '窗体激活事件结束
Private Sub Timer1_Timer() 'timer事件
Randomize '获取随机数种子
Line (3000, 9000 - 100 * yy1)-(11000, 9000 - 100 * yy2), RGB(Int(256 * Rnd), Int(256 * Rnd), Int(256 * Rnd)) '变色拟合线
End Sub
Private Sub txtx_KeyPress(KeyAscii As Integer) '输入框只允许输入数字,小数点和正负号
If (KeyAscii < Asc(0) Or KeyAscii > Asc(9)) And KeyAscii <> 8 And KeyAscii <> 46 And KeyAscii <> 43 And KeyAscii <> 45 And KeyAscii <> 13 Then
KeyAscii = 0
MsgBox "请输入合法数字", vbOKOnly, "警告" '数字不合法提示
txtx.Text = "" 'txtx获得光标
txtx.SetFocus
End If
End Sub
Private Sub txty_KeyPress(KeyAscii As Integer) '输入框只允许输入数字,小数点和正负号
If (KeyAscii < Asc(0) Or KeyAscii > Asc(9)) And KeyAscii <> 8 And KeyAscii <> 46 And KeyAscii <> 43 And KeyAscii <> 45 And KeyAscii <> 13 Then
KeyAscii = 0
MsgBox "请输入合法数字", vbOKOnly, "警告"
txtx.Text = ""
txtx.SetFocus
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -