VBA. Программа поиска и индикации разрывов в контуре

'File: Contur.dvb
Option Explicit
Public Sub SelectLine()
    Dim PointSet As New Collection
    Dim BreakPoints As New Collection
    Dim BreakCircle As New Collection
    Call DeleteCircles
'Create the selection set
    Dim ssetObj As AcadSelectionSet
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Add("SET_LINES")
    If (Err = -2145320851) Then 'set "SET_LINES" exist
        Set ssetObj = ThisDrawing.SelectionSets("SET_LINES")
    End If
    On Error GoTo 0
    ssetObj.Clear
    ssetObj.SelectOnScreen
    Call TerminPoint(ssetObj, PointSet)
    Set ssetObj = Nothing
    Call BreakPoint(PointSet, BreakPoints)
    Call IndicationPoint(BreakCircle, BreakPoints)
    Call SelSet(BreakCircle)
End Sub
Private Sub TerminPoint(ssetObj As AcadSelectionSet, PointSet As Collection)
    Dim Entity As AcadEntity
    Dim LineName As String
    For Each Entity In ssetObj
        LineName = Entity.ObjectName
        Select Case (LineName)
            Case "AcDbLine": Call LineTerminPoint(Entity, PointSet)
            Case "AcDbPolyline": Call PolylineTerminPoint(Entity, PointSet)
            Case "AcDbMline": Call MlineTerminPoint(Entity, PointSet)
            Case "AcDbSpline": Call SplineTerminPoint(Entity, PointSet)
            Case "AcDbArc": Call ArcTerminPoint(Entity, PointSet)
        End Select
    Next Entity
End Sub
Private Sub LineTerminPoint(Entity As AcadLine, PointSet As Collection)
    Dim TerminPoint() As Double
    TerminPoint = Entity.startPoint
    PointSet.Add TerminPoint()
    TerminPoint = Entity.EndPoint
    PointSet.Add TerminPoint()
End Sub
Private Sub PolylineTerminPoint(Entity As AcadLWPolyline, PointSet As Collection)
    Dim ArrayPoint() As Double
    Dim TerminPoint() As Double
    Dim nArray As Long
    ArrayPoint = Entity.Coordinates
    ReDim TerminPoint(2)
    TerminPoint(2) = 0
'start point:
    TerminPoint(0) = ArrayPoint(0)
    TerminPoint(1) = ArrayPoint(1)
    PointSet.Add TerminPoint()
'end point:
    nArray = UBound(ArrayPoint)
    TerminPoint(0) = ArrayPoint(nArray - 1)
    TerminPoint(1) = ArrayPoint(nArray)
    PointSet.Add TerminPoint()
End Sub
Private Sub MlineTerminPoint(Entity As AcadMLine, PointSet As Collection)
    Dim ArrayPoint() As Double
    Dim TerminPoint() As Double
    Dim nArray As Long
    ArrayPoint = Entity.Coordinates
    ReDim TerminPoint(2)
    TerminPoint(2) = 0
'start point:
    TerminPoint(0) = ArrayPoint(0)
    TerminPoint(1) = ArrayPoint(1)
    PointSet.Add TerminPoint()
'end point:
    nArray = UBound(ArrayPoint)
    TerminPoint(0) = ArrayPoint(nArray - 2)
    TerminPoint(1) = ArrayPoint(nArray - 1)
    PointSet.Add TerminPoint()
End Sub
Private Sub SplineTerminPoint(Entity As AcadSpline, PointSet As Collection)
    Dim ArrayPoint() As Double
    Dim TerminPoint() As Double
    Dim nArray As Long
    ArrayPoint = Entity.ControlPoints
    ReDim TerminPoint(2)
    TerminPoint(2) = 0
'start point:
    TerminPoint(0) = ArrayPoint(0)
    TerminPoint(1) = ArrayPoint(1)
    PointSet.Add TerminPoint()
'end point:
    nArray = UBound(ArrayPoint)
    TerminPoint(0) = ArrayPoint(nArray - 2)
    TerminPoint(1) = ArrayPoint(nArray - 1)
    PointSet.Add TerminPoint()
End Sub
Private Sub ArcTerminPoint(Entity As AcadArc, PointSet As Collection)
    Dim TerminPoint() As Double
    TerminPoint = Entity.startPoint
    PointSet.Add TerminPoint()
    TerminPoint = Entity.EndPoint
    PointSet.Add TerminPoint()
End Sub
Private Sub BreakPoint(PointSet As Collection, BreakPoints As Collection)
    Dim TerminPoint() As Double
    Dim Point() As Double
    Dim i As Integer
    Dim j As Integer
    Dim k As Boolean
    For i = 1 To PointSet.Count
        k = True
        TerminPoint() = PointSet(i)
'interior loop:
        For j = 1 To PointSet.Count
            Point() = PointSet(j)
            If (ToAgree(TerminPoint(), Point()) And (i <> j)) Then
                k = False
                Exit For
            End If
        Next j
        If (k) Then
            BreakPoints.Add TerminPoint()
        End If
   Next i
   Set PointSet = Nothing
End Sub
Private Function ToAgree(TerminPoint() As Double, Point() As Double) As Boolean
    ToAgree = False
    If ((CSng(TerminPoint(0)) = CSng(Point(0))) And (CSng(TerminPoint(1)) = CSng(Point(1)))) Then
        ToAgree = True
    End If
End Function
Private Sub IndicationPoint(BreakCircle As Collection, BreakPoints As Collection)
    Dim i As Integer
    Dim Point() As Double
'clear a circle set:
    For i = 1 To BreakCircle.Count
        BreakCircle.Remove (i)
    Next i
    For i = 1 To BreakPoints.Count
        Point() = BreakPoints(i)
        Call MakePoint(Point(), BreakCircle)
    Next i
End Sub
Private Sub MakePoint(BreakPoints() As Double, BreakCircle As Collection)
    Dim ObjectCircle As AcadCircle
    Dim radius As Double
    radius = ThisDrawing.ActiveViewport.Height / 100
    ' Create the point
    Set ObjectCircle = ThisDrawing.ModelSpace.AddCircle(BreakPoints, radius)
    ObjectCircle.Color = acMagenta
    ObjectCircle.Highlight True
    ObjectCircle.Layer = "0"
    BreakCircle.Add ObjectCircle
End Sub
Private Sub SelSet(BreakCircle As Collection)
    Dim i As Integer
'Create the selection set:
    Dim ssetCircle As AcadSelectionSet
    On Error Resume Next
    Set ssetCircle = ThisDrawing.SelectionSets.Add("SET_CIRCLES")
    If (Err = -2145320851) Then 'set "SET_CIRCLES" exist
        Set ssetCircle = ThisDrawing.SelectionSets("SET_CIRCLES")
    End If
    ssetCircle.Clear
'array circles:
    Dim CircleArray() As AcadEntity
    ReDim CircleArray(0 To BreakCircle.Count - 1)
    For i = 1 To (BreakCircle.Count)
       Set CircleArray(i - 1) = BreakCircle(i)
    Next i
    ssetCircle.AddItems CircleArray
End Sub
Public Sub DeleteCircles()
    Dim ssetCircle As AcadSelectionSet
'Create the selection set:
    On Error Resume Next
    Set ssetCircle = ThisDrawing.SelectionSets.Add("SET_CIRCLES")
    If (Err = -2145320851) Then 'set "SET_CIRCLES" exist
        Set ssetCircle = ThisDrawing.SelectionSets("SET_CIRCLES")
    End If
'erase a circles:
    If (ssetCircle.Count > 0) Then
        ssetCircle.Update
        If (Err = -2145386420) Then 'object was erased
            Exit Sub
        End If
        ssetCircle.Erase
       'ThisDrawing.Regen acActiveViewport
    End If
End Sub

(defun C:BP (/ PATH)
  (setq PATH "C:\\Program Files\\Contur\\Contur.dvb")
  (vl-vbaload PATH)
  (vl-vbarun "SelectLine")
  (gc)
)                    ;BP
(defun C:BPD (/ PATH)
  ;;(setq PATH "C:\\Program Files\\Contur\\Contur.dvb")
  ;;(vl-vbaload PATH)
  (vl-vbarun "DeleteCircles")
  (gc)
);BPD