這是我剛剛做的，參考一下吧
我把檔案設定在同資料夾下的 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
