Macro to verify that a rectangle is closed

[Anonymous]

Hello,

For example, I have four lines that they form a rectangle.

I want to verify with a macro that the rectangle is closed.  That the four corners are closed. 

This is the easiest case, but I would like to do it for also more complex form.

I someone knows something that is allready existing I will be happy to see it .

[arcticad]

if it's a polyline then it has the property of closed. otherwise you are going to have to do a selection of the objects around it and test them with intersectwith and see if the end points match up to the same locations.

[Hallex]

See if this helps

Option Explicit


Public Sub TestOnClosed()
    Dim pfs As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim entA As AcadEntity
    Dim entB As AcadEntity
    Dim varPt As Variant
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim dxfCode, dxfValue
    Dim i As Integer
    Dim maxpt As Variant
    Dim minpt As Variant
    Dim xmin As Double
    Dim ymin As Double
    Dim xmax As Double
    Dim ymax As Double
    Dim n As Integer
Dim cnt As Integer
    Dim oLineA As AcadLine
 Dim oLineB As AcadLine
    ftype(0) = 0:
    
    fdata(0) = "LINE"
    
    dxfCode = ftype: dxfValue = fdata
    
    Set pfs = ThisDrawing.PickfirstSelectionSet

    pfs.Clear

    pfs.SelectOnScreen dxfCode, dxfValue

    If pfs.Count <> 4 Then Exit Sub
Dim inters As Boolean
Dim enough As Boolean
Dim pt As Variant
cnt = 0
For n = 0 To pfs.Count - 1
Set entA = pfs.Item(n)
Set oLineA = entA
For i = 0 To pfs.Count - 1
Set entB = pfs.Item(i)
Set oLineB = entB
If entA.ObjectID <> entB.ObjectID Then

pt = entA.IntersectWith(entB, acExtendNone)

If VarType(pt) <> vbEmpty Then
If UBound(pt) = 2 Then
If IsPointsEqual(oLineA.StartPoint, oLineB.StartPoint, 0.001) Or IsPointsEqual(oLineA.StartPoint, oLineB.EndPoint, 0.001) Then
enough = True
cnt = cnt + 1
Else
enough = False
End If
Else
enough = False
End If
End If
End If
Next
Next

If cnt = 4 Then
MsgBox "Closed: True"
Else
MsgBox "Closed: False"
End If

End Sub

Public Function IsPointsEqual(p1 As Variant, p2 As Variant, fuzz As Double) As Boolean
Dim bln As Boolean
If (Abs(p1(0) - p2(0)) < fuzz) And (Abs(p1(1) - p2(1)) < fuzz) And (Abs(p1(2) - p2(2)) < fuzz) Then
bln = True
Else
bln = False

End If
IsPointsEqual = bln
End Function

Not tested, just as articad mentioned above

~'J'~