新建窗体,添加text1,command1,picture1
Private Sub Command1_Click()
If Text1.Text = "" Then Exit Sub
Dim x() As Single, y() As Single, cnt As Integer
Dim xmax As Single, xmin As Single, ymax As Single, ymin As Single
Dim p() As String, z() As String
Dim xyh As Single, xh As Single, yh As Single, xph As Single, k As Single, b As Single
p = Split(Text1.Text, "/")
For i = 0 To UBound(p)
If p(i) <> "" Then
z = Split(p(i), "*")
If UBound(z) = 1 Then
If IsNumeric(z(0)) And IsNumeric(z(1)) Then
If cnt = 0 Then xmax = z(0): xmin = z(0): ymax = z(1): ymin = z(1)
If xmax < z(0) Then xmax = z(0)
If xmin > z(0) Then xmin = z(0)
If ymax < z(1) Then ymax = z(1)
If ymin > z(1) Then ymin = z(1)
xyh = xyh + z(0) * z(1): xh = xh + z(0): yh = yh + z(1): xph = xph + z(0) ^ 2
ReDim Preserve x(cnt), y(cnt)
x(cnt) = z(0): y(cnt) = z(1): cnt = cnt + 1
End If
End If
End If
Next
Picture1.Cls
Picture1.DrawWidth = 1
If xmax = xmin And ymax = ymin Then
MsgBox "单点无法拟合"
ElseIf xmax = xmin Then
Picture1.Scale (xmin * 0.5, ymax + 0.2 * (ymax - ymin))-(xmin * 1.5, ymin - 0.2 * (ymax - ymin))
zuobiaozhou xmin * 0.5, ymax + 0.2 * (ymax - ymin), xmin * 1.5, ymin - 0.2 * (ymax - ymin)
Picture1.Line (xmax, ymax + 0.2 * (ymax - ymin))-(xmax, ymin - 0.2 * (ymax - ymin)), vbBlue
ElseIf ymax = ymin Then
Picture1.Scale (xmin - 0.2 * (xmax - xmin), ymax * 1.5)-(xmax + 0.2 * (xmax - xmin), ymin * 0.5)
zuobiaozhou xmin - 0.2 * (xmax - xmin), ymax * 1.5, xmax + 0.2 * (xmax - xmin), ymin * 0.5
Picture1.Line (xmin - 0.2 * (xmax - xmin), ymax)-(xmax + 0.2 * (xmax - xmin), ymax), vbBlue
Else
Picture1.Scale (xmin - 0.2 * (xmax - xmin), ymax + 0.2 * (ymax - ymin))-(xmax + 0.2 * (xmax - xmin), ymin - 0.2 * (ymax - ymin))
zuobiaozhou xmin - 0.2 * (xmax - xmin), ymax + 0.2 * (ymax - ymin), xmax + 0.2 * (xmax - xmin), ymin - 0.2 * (ymax - ymin)
k = (xyh - (xh * yh) / cnt) / (xph - xh ^ 2 / cnt)
b = yh / cnt - k * xh / cnt
Picture1.Line (xmin - 0.2 * (xmax - xmin), k * (xmin - 0.2 * (xmax - xmin)) + b)-(xmax + 0.2 * (xmax - xmin), k * (xmax + 0.2 * (xmax - xmin)) + b), vbBlue
End If
Picture1.DrawWidth = 5
For i = 0 To cnt - 1
Picture1.PSet (x(i), y(i)), vbRed
Next
Text1.SetFocus
End Sub
Private Sub Form_Activate()
Text1.SetFocus
End Sub
Private Sub Form_Load()
Text1.Text = ""
Text1.ToolTipText = "横纵坐标间以乘号*分隔,各点间以除号/分隔。例如:100*100/200*200"
Command1.Caption = "绘图"
Picture1.AutoRedraw = True
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If Not (IsNumeric(Chr(KeyAscii)) Or KeyAscii = 8 Or KeyAscii = 42 Or KeyAscii = 45 Or KeyAscii = 46 Or KeyAscii = 47) Then KeyAscii = 0
End Sub
Function zuobiaozhou(ByVal x1 As Single, y1 As Single, x2 As Single, y2 As Single)
For i = x1 + (x2 - x1) / 5 To x2 Step (x2 - x1) / 5
Picture1.Line (i, y2 + 100 * (y1 - y2) / Picture1.Height)-(i, y2)
Picture1.CurrentX = i - 250 * (x2 - x1) / Picture1.Width
Picture1.CurrentY = y2 + 350 * (y1 - y2) / Picture1.Height
Picture1.Print i
Next
For i = y2 + (y1 - y2) / 5 To y1 Step (y1 - y2) / 5
Picture1.Line (x1, i)-(x1 + 100 * (x2 - x1) / Picture1.Width, i)
Picture1.CurrentX = x1 + 150 * (x2 - x1) / Picture1.Width
Picture1.CurrentY = i + 80 * (y1 - y2) / Picture1.Height
Picture1.Print i
用vb编写一个直线拟合程序
最新推荐文章于 2021-01-04 03:50:31 发布