I've been testing out this code to detect self-intersecting polygons in ArcPad, but I am getting inconsistent results including a LOT of false positives and some false negatives. I cannot figure out the pattern to the problem. This is based on the code here: How to determine if a polygon is self-intersecting using either ArcPad 8.0 or ArcMap 9.3.1? - Geogra...
Is the issue trying to test this in the office, rather than with real GPS-collected data?
Sub CheckSelfIntersectingPolygon(objSH)
Dim intJ, intI, objPart, objVertex, strVertexNo
'Initialize intJ
intJ = 1
'Display information for each part of the feature
For Each objPart in objSH.Parts
'MsgBox "Part " & intJ & " contains " & objPart.Count & " vertices.",vbOKOnly," Vertex Count"
'Initialize intI
intI = 1
'Display information for each vertex in the current part
For Each objVertex in objPart
strVertexNo = "vertex(" & intI & ") " & objSH.isPointIn(objVertex)
'console.print strVertexNo
if objSH.isPointIn(objVertex) = "True" then
msgbox "This is a self intersecting polygon. You will need to recollect it."
'& VBCr & strVertexNo
exit sub
end if
'Increment intI
intI = intI + 1
Next
'Increment intJ
intJ = intJ + 1
Next
End Sub
Solved! Go to Solution.
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
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
Hi Craig,
Thanks for posting. But can you edit the post and try Posting Code blocks in the new GeoNet
Thank you. Works like a charm!