Latest Contributions by CraigGreenwald

Ingrid, here is the script I sent you - posted here as requested for others to use: Option Explicit Sub TestIt()      If (Map.SelectionLayer Is Nothing) Then           Exit Sub      End If     Dim pRS     Set pRS = Map.SelectionLayer.Records     pRS.Bookmark = Map.SelectionBookmark     Dim pPoly     Set pPoly = pRS.Fields.Shape     msgbox "Self intersects: " & IsSelfIntersectingPoly(pPoly) End Sub Call TestIt() Function IsSelfIntersectingPoly(p_pPolygon)     '++ if input shape is not a polygon, return false     If (TypeName(p_pPolygon) <> "ISPolygon") Then         IsSelfIntersecting = False         Exit Function     End If        '++ build segments     Dim pLineSeg, pPts, pPt     Dim arrSegments()     ReDim arrSegments(p_pPolygon.Parts(1).Count - 2)     Dim iSegCt     For iSegCt = 1 To UBound(arrSegments)+1         Set pLineSeg = Application.CreateAppObject("Line")         Set pPts = Application.CreateAppObject("Points")         Set pPt = p_pPolygon.Parts(1)(iSegCt)         pPts.Add pPt         Set pPt = p_pPolygon.Parts(1)(iSegCt+1)         pPts.Add pPt         pLineSeg.Parts.Add pPts         Set arrSegments(iSegCt-1) = pLineSeg     Next     Dim i,j     For i = 0 To UBound(arrSegments) - 1         For j = (i+1) To UBound(arrSegments)             If (DoLineSegmentsCross(arrSegments(i),arrSegments(j))) Then                 IsSelfIntersectingPoly = True                 Exit Function             End If         Next     Next     IsSelfIntersectingPoly = False End Function '++ Routines below adapted from Peter Kelley's solution posted at: '++ https://github.com/pgkelley4/line-segments-intersect/blob/master/js/line-segments-intersect.js Function DoLineSegmentsCross(p_Seg1, p_Seg2)     Dim pSeg1Pt1, pSeg1Pt2, pSeg2Pt1, pSeg2Pt2     Set pSeg1Pt1 = p_Seg1.Parts(1)(1)     Set pSeg1Pt2 = p_Seg1.Parts(1)(2)     Set pSeg2Pt1 = p_Seg2.Parts(1)(1)     Set pSeg2Pt2 = p_Seg2.Parts(1)(2)     '++ intersection at nodes is ok     If (EqualPoints(pSeg1Pt1, pSeg2Pt1) Or EqualPoints(pSeg1Pt1, pSeg2Pt2) Or EqualPoints(pSeg1Pt2, pSeg2Pt1) Or EqualPoints(pSeg1Pt2, pSeg2Pt2)) Then             DoLineSegmentsCross = False             Exit Function     End If     Dim r,s     Set r = SubtractPoints(pSeg1Pt2, pSeg1Pt1)     Set s = SubtractPoints(pSeg2Pt2, pSeg2Pt1)     Dim uNumerator,denominator     uNumerator = CrossProduct(SubtractPoints(pSeg2Pt1, pSeg1Pt1), r)     denominator = CrossProduct(r, s)     If (uNumerator = 0 And denominator = 0) Then         '++ they are colinear         '++ do they overlap? (are all the point differences in either direction the same sign?)         Dim bOverlapTest         bOverlapTest = ((pSeg2Pt1.x - pSeg1Pt1.x < 0) XOr (pSeg2Pt1.x - pSeg1Pt2.x < 0) Xor (pSeg2Pt2.x - pSeg1Pt1.x < 0) Xor (pSeg2Pt2.x - pSeg1Pt2.x < 0)) Or _             ((pSeg2Pt1.y - pSeg1Pt1.y < 0) XOr (pSeg2Pt1.y - pSeg1Pt2.y < 0) XOr (pSeg2Pt2.y - pSeg1Pt1.y < 0) XOr (pSeg2Pt2.y - pSeg1Pt2.y < 0))         DoLineSegmentsCross = bOverlapTest         Exit Function     End If     If (denominator = 0) Then         '++ lines are parallel         DoLineSegmentsCross = False         Exit Function     End If     Dim u,t     u = uNumerator / denominator     t = CrossProduct(SubtractPoints(pSeg2Pt1, pSeg1Pt1), s) / denominator     DoLineSegmentsCross = ((t >= 0) And (t <= 1) And (u >= 0) And (u <= 1)) End Function Function CrossProduct(p_P1, p_P2)     CrossProduct = p_P1.X * p_P2.Y - p_P1.Y * p_P2.X End Function Function SubtractPoints(p_P1, p_P2)     Dim pResultPt     Set pResultPt = Application.CreateAppObject("Point")     pResultPt.X = p_P1.X - p_P2.X     pResultPt.Y = p_P1.Y - p_P2.Y     Set SubtractPoints = pResultPt End Function Function EqualPoints(p_P1, p_P2)     EqualPoints = (p_P1.X = p_P2.X) And (p_P1.Y = p_P2.Y) End Function ... View more