﻿'--------------------------------------------------------------------------------------------------------- '************************************ Routine LinesSegmentsIntersect ************************************* '--------------------------------------------------------------------------------------------------------- 'VBA implementation of the theory provided by Paul Bourke (http://paulbourke.net/geometry/pointlineplane/) 'author: ing. Giuseppe Iaria - rev. 07/08/2014 '--------------------------------------------------------------------------------------------------------- 'Routine determines the intersection point of two line segments 'defined by their respective end points P1-P2 and P3-P4 'If exsists, actual point P of intersection is returned, otherwise point P is set to (0,0) 'Both conditions of lines and segments intersection are valued and returned 'Routine arguments are defined as follows: 'Points P1 (x1 ; y1), P2 (x2 ; y2), P3 (x3 ; y3), P4 (x4 ; y4), P (xP ; yP) 'Condition of lines intersection: LinesIntersection 'Condition of segments intersection: SegmentsIntersection '--------------------------------------------------------------------------------------------------------- Public Sub LinesSegmentsIntersect(ByVal x1 As Double, ByVal y1 As Double, _ ByVal x2 As Double, ByVal y2 As Double, _ ByVal x3 As Double, ByVal y3 As Double, _ ByVal x4 As Double, ByVal y4 As Double, _ ByRef xP As Double, ByRef yP As Double, _ ByRef LinesIntersection As Boolean, ByRef SegmentsIntersection As Boolean) Dim NumA As Double, NumB As Double, DeNom As Double Dim uA As Double, uB As Double Const EPS As Single = 0.0001 NumA = (x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3) NumB = (x2 - x1) * (y1 - y3) - (y2 - y1) * (x1 - x3) DeNom = (y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1) 'Verify if lines are coincident 'if they do, the poit P is given back as midpoint of midpoints of both segments If Abs(NumA) < EPS And Abs(NumB) < EPS And Abs(DeNom) < EPS Then LinesIntersection = True xP = (x1 + x2 + x3 + x4) / 4 yP = (y1 + y2 + y3 + y4) / 4 Exit Sub End If 'Verify if lines are parallel 'if they do, no intersection occurs, the point P is given back as (0,0) If Abs(DeNom) < EPS Then LinesIntersection = False xP = 0 yP = 0 Exit Sub End If 'An intersection between the lines exists 'and the coordinates of point of intersection P are given back LinesIntersection = True uA = NumA / DeNom uB = NumB / DeNom xP = x1 + uA * (x2 - x1) yP = y1 + uA * (y2 - y1) 'Verify if the point P is inside both segments If uA < 0 Or uA > 1 Or uB < 0 Or uB > 1 Then SegmentsIntersection = False Else SegmentsIntersection = True End Sub