如何记录鼠标在PictureBOX上的运动轨迹？

Question

如何在PictureBOX上，当触发Picture_MouseMove时开始记录鼠标运动轨迹，当触发Picture_MouseMove的Button = 2 时结束记录，并用一个或多个Dim Rrx As Double记录全部鼠标所经过的轨迹？或用什么方法实现也可，望高人指教，谢谢！

Answer 1

Option Explicit
    Private Type PointAPI
        X As Long
        Y As Long
    End Type
    Dim MousePos As PointAPI
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As LongPrivate Sub Form_Load()
    Timer1.Interval = 100
    GetCursorPos MousePos
    Me.BorderStyle = 0
End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = False
End SubPrivate Sub Picture1_Click()
    End
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = True
End SubPrivate Sub Timer1_Timer()
    GetCursorPos MousePos
    Text1 = MousePos.X * Screen.TwipsPerPixelX - (Me.Left + Picture1.Left) '获得X坐标
    Text2 = MousePos.Y * Screen.TwipsPerPixelY - (Me.Top + Picture1.Top) '获得Y坐标
End Sub

Answer 2

不响应鼠标按按下、释放事件？比较怪的需求
Option ExplicitPrivate m_Capacity As Long
Private m_Count As Long
Private m_XArray() As Single
Private m_YArray() As SinglePrivate Sub AddPoint(ByVal x As Single, ByVal y As Single)
    If m_Count = m_Capacity Then
        m_Capacity = m_Capacity + 64
        ReDim Preserve m_XArray(m_Capacity - 1)
        ReDim Preserve m_YArray(m_Capacity - 1)
    End If
    m_XArray(m_Count) = x
    m_YArray(m_Count) = y
    m_Count = m_Count + 1
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button <> vbRightButton Then
        AddPoint x, y
    End If
End Sub

Answer 3

上述代码是实时获取鼠标在PictureBOX上的X及Y坐标值.

Answer 4

Option Explicit
    Private Type PointAPI
        X As Long
        Y As Long
    End Type
    Dim MousePos As PointAPI
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As LongPrivate Sub Form_Load()
    Timer1.Interval = 100
    GetCursorPos MousePos
    Me.BorderStyle = 0
End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = False
End SubPrivate Sub Picture1_Click()
    End
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = True
End SubPrivate Sub Timer1_Timer()
    GetCursorPos MousePos
    Text1 = MousePos.X * Screen.TwipsPerPixelX - (Me.Left + Picture1.Left) '获得X坐标
    Text2 = MousePos.Y * Screen.TwipsPerPixelY - (Me.Top + Picture1.Top + 450) '获得Y坐标
    Open "c:\12345.txt" For Append As #1
        Print #1, Text1 & " " & Text2
    Close #1
End Sub

Answer 5

Private Type PointAPI
        X As Long
        Y As Long
    End Type
   Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As LongPrivate Sub Form_Load()
Picture1.ScaleMode = 3
Picture1.AutoRedraw = True
End Sub
Private Sub Timer1_Timer()
Dim MousePos As PointAPI
GetCursorPos MousePosPicture1.PSet (MousePos.X, MousePos.Y), vbRed
End Sub

Answer 6

需求就是像在PictureBOX上随意画一条曲线，但要求记录鼠标所经过的轨迹。

Answer 7

这是用鼠标左键画一条线
Option ExplicitPrivate m_Capacity As Long
Private m_Count As Long
Private m_XArray() As Single
Private m_YArray() As Single
Private m_bTrace As BooleanPrivate Sub Clear()
    Picture1.Cls
    m_Capacity = 0
    m_Count = 0
    Erase m_XArray
    Erase m_YArray
End SubPrivate Sub AddPoint(ByVal X As Single, ByVal Y As Single)
    If m_Count = 0 Then
        Picture1.CurrentX = X
        Picture1.CurrentY = Y
    Else
        Picture1.Line -(X, Y)
    End If
    If m_Count = m_Capacity Then
        m_Capacity = m_Capacity + 64
        ReDim Preserve m_XArray(m_Capacity - 1)
        ReDim Preserve m_YArray(m_Capacity - 1)
    End If
    
    m_XArray(m_Count) = X
    m_YArray(m_Count) = Y
    m_Count = m_Count + 1
End SubPrivate Sub Form_Load()
    Picture1.AutoRedraw = True
    Picture1.ScaleMode = vbPixels
End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        m_bTrace = True
        Clear
        AddPoint X, Y
    End If
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If m_bTrace Then
        AddPoint X, Y
    End If
End SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        AddPoint X, Y
        m_bTrace = False
    End If
End Sub

Answer 8

LZ：
你将XY坐标赋值给数组，按LINE方法或PSET方法不就可绘制坐标轨迹吗？

Answer 9

这是在VB150中提供的代码修改的。
Option Explicit
    Dim x1 As Integer   '起点X坐标
    Dim y1 As Integer   '起点Y坐标
    Dim x2 As Integer   '终点点X坐标
    Dim y2 As Integer   '终点Y坐标
    Dim flag As Boolean '绘图标志'设置线的颜色
Private Sub Command1_Click()
    On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "颜色"
    CommonDialog1.ShowColor
    If Err <> 32755 Then
        Picture1.ForeColor = CommonDialog1.Color
    End If
End Sub'清除Picture1中的图形
Private Sub Command2_Click()
    Picture1.Cls
End Sub'设置线宽
Private Sub Option1_Click()
    Picture1.DrawWidth = 1
End SubPrivate Sub Option2_Click()
    Picture1.DrawWidth = 2
End SubPrivate Sub Option3_Click()
    Picture1.DrawWidth = 4
End SubPrivate Sub Option4_Click()
    Picture1.DrawWidth = 8
End SubPrivate Sub Form_Load()
    Picture1.Scale (0, 0)-(400, 400)
    flag = False
End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
'当按下鼠标按键时绘图开始并记录最初的起点
    flag = True
    x1 = X
    y1 = Y
    Timer1.Enabled = True
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
'如果不是处在绘图状态则退出该过程
'如果处在绘图状态则从起点到目前鼠标所在点绘制直线
'然后将当前鼠标所在点作为新的起点
    If flag = False Then
        Exit Sub
    End If
    If flag = True Then
        x2 = X
        y2 = Y
        Picture1.Line (x1, y1)-(x2, y2)
        x1 = x2
        y1 = y2
    End If
End SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _
                             X As Single, Y As Single)
'当释放鼠标按键时绘图结束
    flag = False
    Timer1.Enabled = False
End SubPrivate Sub Timer1_Timer()
    Open "c:\12345.txt" For Append As #1
        Print #1, x1 & " " & y1
    Close #1
End Sub

Answer 10

谢谢各位，特别是zdingyun

Answer 11

LZ:中午贴的代码漏了不少,现补上:
Option Explicit
    Dim x1 As Integer   '起点X坐标
    Dim y1 As Integer   '起点Y坐标
    Dim x2 As Integer   '终点点X坐标
    Dim y2 As Integer   '终点Y坐标
    Dim flag As Boolean '绘图标志'设置线的颜色
Private Sub Command1_Click()
    On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "颜色"
    CommonDialog1.ShowColor
    If Err <> 32755 Then
        Picture1.ForeColor = CommonDialog1.Color
    End If
End Sub'清除Picture1中的图形
Private Sub Command2_Click()
    Picture1.Cls
End Sub'设置线宽
Private Sub Option1_Click()
    Picture1.DrawWidth = 1
End SubPrivate Sub Option2_Click()
    Picture1.DrawWidth = 2
End SubPrivate Sub Option3_Click()
    Picture1.DrawWidth = 4
End SubPrivate Sub Option4_Click()
    Picture1.DrawWidth = 8
End SubPrivate Sub Form_Load()
    Picture1.Scale (0, 0)-(400, 400)
    flag = False
    Timer1.Interval = 50
    Timer1.Enabled = False
End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'当按下鼠标按键时绘图开始并记录最初的起点
    flag = True
    x1 = X
    y1 = Y
    Timer1.Enabled = True
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'如果不是处在绘图状态则退出该过程
'如果处在绘图状态则从起点到目前鼠标所在点绘制直线
'然后将当前鼠标所在点作为新的起点
    If flag = False Then
        Exit Sub
    End If
    If flag = True Then
        x2 = X
        y2 = Y
        Picture1.Line (x1, y1)-(x2, y2)
        x1 = x2
        y1 = y2
    End If
End SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'当释放鼠标按键时绘图结束
    flag = False
    Timer1.Enabled = False
End SubPrivate Sub Timer1_Timer()
    Open "c:\12345.txt" For Append As #1
        Print #1, x1 & " " & y1
    Close #1
End Sub