Preventing Self-Intersecting Polygons

[IngridHogle]

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

[CraigGreenwald · Accepted 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

[RebeccaStrauch__GISP]

Hi Craig,

Thanks for posting.  But can you edit the post and try Posting Code blocks in the new GeoNet​

[IngridHogle]

Thank you. Works like a charm!