这是我刚刚做的，参考一下吧
我把档案设定在同资料夹下的 Pos.txt 里面
格式是 X,Y 例如
1,4
2,5
3,6
不过既然你给三个数值，那么程式可能就会绘出两条以上的线，取决于在 Pos.txt 的资料行数有几个 - 1
先创建 一些元件在 Form1 ，以下格式是 元件：名称
按钮(CommandButton)：CMD_OK
文字框(TextBox)：Text_See
计时器(Timer)：Timer_MoveLine
标签(Label)：Label_Slope
图片(PictureBox)：Pic
还有要一个模组
不过我有把专案上传，可以直接下载专案来看
我是还有加几个东西，例如斜率的显示、座标的显示，那些都可以删除
以下在 MainForm 表单： 复制程式
Option Explicit
Dim PtX As New Collection
Dim PtY As New Collection
Dim Dis As Long
Dim DataCount As Long
Dim TimeAddUp As Long
Dim TimeSep As Long
Dim OriX As Long
Dim OriY As Long
'Made By EbolaMan, 哪里不懂就回复吧
Private Sub CMD_OK_Click()
ApplyPos
Timer_MoveLine.Enabled = True
RefreshStatus '@@@@ Test Sub
End Sub
Private Sub Form_Initialize()
'-------------- Ini. Constant Obj --------------
Set fso = CreateObject("Scripting.FileSystemObject")
End Sub
Private Sub Form_Load()
Dim tempS As String
Dim txtpath As String
Dim ArrText() As String
Dim i As Long
'-------------- Set Program-Local Array Data -------------
'## Way1 这是不用开启资料夹下的档案就可以直接绘图的程式码，与底下的择一，不过依照你的方法，应该是要下面那种
'PtX.Add 1
'PtX.Add 2
'PtX.Add 3
'
'PtY.Add 4
'PtY.Add 5
'PtY.Add 6
'## Way2 开启资料夹下的档案读取 POS 值
txtpath = App.Path & "\Pos.txt" '读取资料夹下的 Pos.txt ，可改
tempS = LoadData(txtpath)
ReDim Pt(0, 1)
If tempS <> "" Then
ArrText = Split(tempS, vbCrLf)
For i = 0 To UBound(ArrText)
LoadNewPos Trim(ArrText(i))
Next i
End If
'------------- Ori Pos ---------------
If DataCount <> 0 Then
OriX = PtX.Item(1)
OriY = PtY.Item(1)
End If
'---------------- Ini. Variable ---------------
Dis = 100 '为避免点的值太小，加入 Distance 来增加点与点的距离，此项设 1 则是原本的点值，越大点的距离越大
'DataCount = 3 '与 Way1 连用，Way 1 失效此也失效
TimeAddUp = 0
TimeSep = 1000 '每次更新 LINE 时间的间隔
'--------- Ini. Obj ---------
With Pic
.AutoRedraw = True
.DrawWidth = 2
End With
Timer_MoveLine.Interval = TimeSep
End Sub
Public Sub ApplyPos()
Dim i As Long
Dim tempX As Double
Dim tempY As Double
Pic.Cls
For i = 1 To DataCount - 1
'画出实线
Pic.DrawWidth = 2
Pic.DrawStyle = 0
Pic.Line (PtX.Item(i) * Dis, PtY.Item(i) * Dis)-(PtX.Item(i + 1) * Dis, PtY.Item(i + 1) * Dis), RGB(0, 0, 0)
'画出原点到最近实线
Pic.DrawWidth = 5
Pic.PSet (OriX * Dis, OriY * Dis), RGB(10, 120, 240)
'画出原点
Pic.DrawWidth = 1
Pic.DrawStyle = 2
Pic.Line (OriX * Dis, OriY * Dis)-(PtX.Item(i) * Dis, PtY.Item(i) * Dis)
'计算斜率
tempX = (PtX.Item(i + 1) - PtX.Item(i))
tempY = (PtY.Item(i + 1) - PtY.Item(i))
If tempY <> 0 Then
Label_Slope = "Slope = [Selected] " & Format(tempX / tempY, "0.0##")
Else
Label_Slope = "Slope = [Selected] No "
End If
tempX = (PtX.Item(i) - OriX)
tempY = (PtY.Item(i) - OriY)
If tempY <> 0 Then
Label_Slope = Label_Slope & " [From Ori] " & Format(tempX / tempY, "0.0##")
Else
Label_Slope = Label_Slope & " [From Ori] No "
End If
Next i
End Sub
Public Sub ApplyNewLinePos(ByVal Ind As Long, ByVal Value As Long)
Dim i As Long
For i = 1 To DataCount
ResetValue Ind, i, IIf(Ind = 0, PtX.Item(i), PtY.Item(i)) + Value
Next i
End Sub
Private Sub Timer_MoveLine_Timer()
TimeAddUp = TimeAddUp + 1 'Before
ApplyNewLinePos 0, 1
ApplyNewLinePos 1, 1
ApplyPos
RefreshStatus '@@ Test Sub
End Sub
Public Sub LoadNewPos(ByVal S As String)
Dim m As Long
Dim Pos_X As Long
Dim Pos_Y As Long
On Error Resume Next
If Trim(S) = "" Then Exit Sub
m = InStr(1, S, ",")
Pos_X = Trim(Left(S, m - 1))
Pos_Y = Trim(Right(S, Len(S) - m))
PtX.Add Pos_X
PtY.Add Pos_Y
DataCount = DataCount + 1
End Sub
Public Sub ResetValue(ByVal X_or_Y_0_or_1 As Integer, ByVal Floor As Long, ByVal Value As Long)
On Error Resume Next
If X_or_Y_0_or_1 = 0 Then
PtX.Remove Floor
If Floor - 1 >= PtX.Count Then
PtX.Add Value
Else
PtX.Add Value, , Floor
End If
Else
PtY.Remove Floor
If Floor - 1 >= PtY.Count Then
PtY.Add Value
Else
PtY.Add Value, , Floor
End If
End If
End Sub
Public Sub RefreshStatus() '@@@@ Test Sub
Dim i As Long
Text_See.Text = ""
For i = 1 To 3
Text_See.Text = Text_See.Text & "(" & PtX.Item(i) & ", " & PtY.Item(i) & ")" & vbCrLf
Next i
End Sub
以下在 File 模组：
复制程式
Option Explicit
Public fso As FileSystemObject '此模组最主要都是用这种 FileSystemObject 来使用写入写出功能，如果你不喜欢就把此模组砍了吧
'如果启用，请记得引用项目 Microsoft Script Runtime
Public Function LoadData(ByVal FileName As String) As String
'Dim f As New FileSystemObject
Dim tempTextStream As TextStream
On Error Resume Next
Set tempTextStream = fso.OpenTextFile(FileName)
LoadData = ""
If Not tempTextStream.AtEndOfStream Then
LoadData = tempTextStream.ReadAll
tempTextStream.Close
End If
End Function
Public Sub WriteData(ByVal FileName As String, ByVal WrittenMes As String)
Dim fr As Long
'Dim f As New FileSystemObject
Dim tempTextStream As TextStream
On Error Resume Next
Set tempTextStream = fso.CreateTextFile(FileName)
tempTextStream.Write WrittenMes
tempTextStream.Close
End Sub
Public Sub WriteData_Add(ByVal FileName As String, ByVal WrittenMes As String)
Dim f As Long
f = FreeFile
Open FileName For Append As #f
Print #f, WrittenMes
Close #f
End Sub
Public Function FileExt(ByVal FileN As String) As Boolean
FileExt = IIf(Dir(FileN, vbNormal Or vbHidden Or vbReadOnly Or vbSystem) <> "", True, False)
End Function
