form1.frm

intersection point of the two lines

VERSION 5.00
Begin VB.Form Form1 
   AutoRedraw      =   -1  'True
   Caption         =   "Form1"
   ClientHeight    =   6030
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6930
   LinkTopic       =   "Form1"
   ScaleHeight     =   402
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   462
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox picView 
      BackColor       =   &H80000009&
      Height          =   5055
      Left            =   120
      ScaleHeight     =   333
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   437
      TabIndex        =   0
      Top             =   120
      Width           =   6615
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   495
      Left            =   120
      TabIndex        =   1
      Top             =   5400
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type POINT2D
    X As Long
    Y As Long
End Type

Dim m_Points(1 To 4) As POINT2D
Dim m_LastPoint As Integer
Dim m_LastX As Single
Dim m_LastY As Single

Private Sub picView_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' Get the next point.
    m_LastPoint = m_LastPoint + 1

    ' See if we need to start a new series of lines.
    If m_LastPoint = 5 Then
        m_LastPoint = 1
        picView.Cls
    End If

    ' Save the point.
    With m_Points(m_LastPoint)
        .X = X
        .Y = Y
        m_LastX = X
        m_LastY = Y
        picView.Circle (X, Y), 2, vbBlack
    End With

    ' Start rubberband drawing.
    picView.DrawMode = vbInvert
End Sub

Private Sub picView_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Label1.Caption = "X:" & X & ",Y:" & Y
    ' Only draw a line if we are working on
    ' the second or fourth point.
    If m_LastPoint <> 1 And m_LastPoint <> 3 Then Exit Sub

    With m_Points(m_LastPoint)
        ' Erase the last line.
        picView.Line (.X, .Y)-(m_LastX, m_LastY)

        ' Save the new point.
        m_LastX = X
        m_LastY = Y

        ' Draw the new line.
        picView.Line (.X, .Y)-(m_LastX, m_LastY)
    End With
End Sub

Private Sub picView_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' Save the new point.
    m_LastPoint = m_LastPoint + 1
    With m_Points(m_LastPoint)
        .X = m_LastX
        .Y = m_LastY
        picView.Circle (X, Y), 2, vbBlack
    End With

    ' Draw the new line.
    With m_Points(m_LastPoint - 1)
        picView.DrawMode = vbCopyPen
        picView.Line (.X, .Y)-(m_LastX, m_LastY), vbBlack
    End With

    ' See if this is the last point.
    If m_LastPoint = 4 Then
        IntersectLines
    End If
End Sub

' Display the intersection information.
Private Sub IntersectLines()
    Dim X As Single, Y As Single
    Dim X1 As Single, Y1 As Single
    Dim X2 As Single, Y2 As Single

    ' See where the segments intersect.
    FindLineIntersection m_Points(1).X, m_Points(1).Y, _
                         m_Points(2).X, m_Points(2).Y, _
                         m_Points(3).X, m_Points(3).Y, _
                         m_Points(4).X, m_Points(4).Y, _
                         X, Y, X1, Y1, X2, Y2
    If X >= 1E+38 Then
        ' The lines are parallel.
        MsgBox "Parallel"
    Else
        ' Draw the various points.
        If X1 <> X2 Or Y1 <> Y2 Then
            picView.DrawStyle = vbDot
            picView.Line (X, Y)-(X1, Y1), vbBlack
            picView.Line (X, Y)-(X2, Y2), vbBlack
            picView.DrawStyle = vbSolid
        End If
        picView.Circle (X, Y), 2, vbRed
    End If
End Sub

Public Sub FindLineIntersection(ByVal x11 As Single, ByVal y11 As Single, _
                                ByVal x12 As Single, ByVal y12 As Single, _
                                ByVal x21 As Single, ByVal y21 As Single, _
                                ByVal x22 As Single, ByVal y22 As Single, _
                                ByRef inter_x As Single, ByRef inter_y As Single, _
                                ByRef inter_x1 As Single, ByRef inter_y1 As Single, _
                                ByRef inter_x2 As Single, ByRef inter_y2 As Single)

    Dim dx1 As Single, dy1 As Single
    Dim dx2 As Single, dy2 As Single
    Dim t1 As Single, t2 As Single
    Dim denominator As Single

    ' Get the segments' parameters.
    dx1 = x12 - x11
    dy1 = y12 - y11
    dx2 = x22 - x21
    dy2 = y22 - y21

    ' Solve for t1 and t2.
    On Error Resume Next
    denominator = (dy1 * dx2 - dx1 * dy2)
    t1 = ((x11 - x21) * dy2 + (y21 - y11) * dx2) / denominator
    If Err.Number <> 0 Then
        ' The lines are parallel.
        inter_x = 1E+38:          inter_y = 1E+38
        inter_x1 = 1E+38:         inter_y1 = 1E+38
        inter_x2 = 1E+38:         inter_y2 = 1E+38
        Exit Sub
    End If
    On Error GoTo 0
    t2 = ((x21 - x11) * dy1 + (y11 - y21) * dx1) / -denominator

    ' Find the point of intersection.
    inter_x = x11 + dx1 * t1
    inter_y = y11 + dy1 * t1

    ' Find the closest points on the segments.
    If t1 < 0 Then
        t1 = 0
    ElseIf t1 > 1 Then
        t1 = 1
    End If
    If t2 < 0 Then
        t2 = 0
    ElseIf t2 > 1 Then
        t2 = 1
    End If
    inter_x1 = x11 + dx1 * t1
    inter_y1 = y11 + dy1 * t1
    inter_x2 = x21 + dx2 * t2
    inter_y2 = y21 + dy2 * t2
End Sub