VB 判断两条线段是否相交

' 自定义点结构体
Private Type Point
    x As Double
    y As Double
End Type

' 自定义矩形结构体
Private Type Rectangle
    xMin As Double
    xMax As Double
    yMin As Double
    yMax As Double
End Type

' 计算两矢量的叉积
Private Function ChaJi(p As Point, q As Point) As Double
    ChaJi = p.x * q.y - p.y * q.x
End Function

' 计算两矢量的差
Private Function Cha(p As Point, q As Point) As Point
    Dim t As Point
    t.x = p.x - q.x
    t.y = p.y - q.y
    Cha = t
End Function

' 以两点为对角顶点创建一个矩形
Private Function CreateRectangle(p As Point, q As Point) As Rectangle
    Dim rec As Rectangle
    rec.xMin = p.x
    rec.xMax = q.x
    rec.yMin = p.y
    rec.yMax = q.y
    
    If rec.xMin > rec.xMax Then
        t = rec.xMin
        rec.xMin = rec.xMax
        rec.xMax = t
    End If
    
    If rec.yMin > rec.yMax Then
        t = rec.yMin
        rec.yMin = rec.yMax
        rec.yMax = t
    End If
    
    CreateRectangle = rec
End Function


' 算法7：判断点是否在矩形内
Private Function PointInRec(p As Point, r As Rectangle) As Boolean
    If r.xMin <= p.x And p.x <= r.xMax And r.yMin <= p.y And p.y <= r.yMax Then
        PointInRec = True
    Else
        PointInRec = False
    End If
End Function

' 算法2：判断点是否在线段上（p为一点，s和e分别为线段的起点和终点）
Private Function PointOnSegment(p As Point, s As Point, e As Point) As Boolean

    ' 创建外接矩形
    Dim rec As Rectangle
    rec = CreateRectangle(s, e)
    
    ' 判断点是否在线段上
    If Not PointInRec(p, rec) Then                ' 如果点在线段的外接矩形外，则必定不在线段上，直接返回假
        PointOnSegment = False
    Else
        If ChaJi(Cha(p, s), Cha(e, s)) = 0 Then   ' 如果点在外接矩形内，则继续计算叉积，判断点是否在线段所在的直线上
            PointOnSegment = True
        Else
            PointOnSegment = False
        End If
    End If
        
End Function
Private Function min(a As Double, b As Double) As Double
min = a
If min > b Then min = b
End Function

Private Function max(a As Double, b As Double) As Double
max = b
If max < b Then max = b
End Function


' 算法3：判断两线段是否相交
Private Function SegmentCross(p1 As Point, p2 As Point, p3 As Point, p4 As Point) As Boolean
If _
Not (min(p1.x, p2.x) <= max(p3.x, p4.x) And _
min(p3.y, p4.y) <= max(p1.y, p2.y) And _
min(p3.x, p4.x) <= max(p1.x, p2.x) And _
min(p1.y, p2.y) <= max(p3.y, p4.y)) _
Then

SegmentCross = False
Exit Function
End If

Dim u As Double
Dim v As Double
Dim w As Double
Dim z As Double

       u = (p3.x - p1.x) * (p2.y - p1.y) - (p2.x - p1.x) * (p3.y - p1.y)
       v = (p4.x - p1.x) * (p2.y - p1.y) - (p2.x - p1.x) * (p4.y - p1.y)
       w = (p1.x - p3.x) * (p4.y - p3.y) - (p4.x - p3.x) * (p1.y - p3.y)
       z = (p2.x - p3.x) * (p4.y - p3.y) - (p4.x - p3.x) * (p2.y - p3.y)
       SegmentCross = (u * v <= 0.00000001 And w * z <= 0.00000001)
End Function

' 测试“算法2：判断点是否在线段上”
Private Sub Command1_Click()
    ' 定义点和线段端点
    Dim p As Point, s As Point, e As Point, f As Point
    
    ' 定义存放结果的字符串
    Dim Result As String
    
    ' 读取测试数据
    Dim filename As String  ' 数据文件完整路径和文件名
    Dim DataLine As String  ' 读取出的一行数据
    Dim Datas() As String   ' 将一行数据分解后存储在这个数组中
    
    ' 打开测试文件
    filename = "E:\《地理信息系统算法》上机\test2.txt"   ' 设置测试数据路径
    filename = App.Path & "\test3.txt"   ' 设置测试数据路径
    Open filename For Input As #1   ' 打开txt文件
    
    ' 读取测试数据并测试函数
    For i = 1 To 7
        Line Input #1, DataLine         ' 读取一行数据至字符串DataLine
        Datas = Split(DataLine, " ")    ' 将一行数据分成6个值，存在数组Datas中
        
        ' 从字符串中提取6个坐标值
        p.x = Val(Datas(0))
        p.y = Val(Datas(1))
        s.x = Val(Datas(2))
        s.y = Val(Datas(3))
        e.x = Val(Datas(4))
        e.y = Val(Datas(5))
        f.x = Val(Datas(6))
        f.y = Val(Datas(7))
        
        res = PointOnSegment(p, s, e)
        res = SegmentCross(p, s, e, f)
        Line1.X1 = Int(p.x) * 100
        Line1.Y1 = Int(p.y) * 100
        
        Line1.X2 = Int(s.x) * 100
        Line1.Y2 = Int(s.y) * 100
        
        Line2.X1 = e.x * 100
        Line2.Y1 = e.y * 100
        
        Line2.X2 = f.x * 100
        Line2.Y2 = f.y * 100
        
        MsgBox i
        If res = True Then      ' 点在线段上
            Result = Result & "1"
        Else                    ' 点不在线段上
            Result = Result & "0"
        End If
    Next
    
    ' 关闭测试文件
    Close #1
    
    Print Result

End Sub