How to find the entries in a region?

[markc0826]

If there are many rectangs and circles in the drawing. How can I use VBA to find the entries in a region(maybe boundary or closed polyline)? As below, You will find 3 rectangs and 2 circles...

[Hallex · Accepted solution]

Found this one from my old library

Give that a try

Option Explicit
Sub TestSelection()
     Dim oPoly As AcadLWPolyline
     Dim oEnt As AcadEntity
     Dim varPt As Variant
     Dim vexPt As Variant
     Dim i As Integer
     Dim j As Integer
     Dim vxsArr() As Variant
     Dim outArr() As Variant
     ThisDrawing.Utility.GetEntity oEnt, varPt, "Select polyline"
     Set oPoly = oEnt
     i = (UBound(oPoly.Coordinates) + 1) \ 2 - 1
     For j = 0 To i
          vexPt = oPoly.Coordinate(j)
          ReDim Preserve vxsArr(j)
          vxsArr(j) = vexPt
     Next
     outArr = ConvTo3dPoints(FlattenArray(RemoveDupVexs(vxsArr)), oPoly.Elevation)
     ReDim ptArr(0 To UBound(outArr)) As Double
     For i = 0 To UBound(outArr)
          ptArr(i) = CDbl(outArr(i))
     Next

     Dim setObj As AcadSelectionSet
     Dim setColl As AcadSelectionSets
     Dim objEnt As AcadEntity
     Dim plineObj As AcadLWPolyline
     Dim oText As AcadText
     Dim pickPnt As Variant
     Dim setName As String
     Dim selMod As Long
     Dim vertPts As Variant
     Dim dblElv As Double
     Dim gpCode(0 To 7) As Integer
     Dim dataValue(0 To 7) As Variant
     Dim dxfcode, dxfdata
     Dim selPts As Variant

     On Error GoTo Err_Control
gpCode(0) = -4: dataValue(0) = "<OR"
gpCode(1) = 0: dataValue(1) = "CIRCLE"
gpCode(2) = -4: dataValue(2) = "<AND"
gpCode(3) = 0: dataValue(3) = "LWPOLYLINE"
gpCode(4) = 70: dataValue(4) = 1
gpCode(5) = 90: dataValue(5) = 4
gpCode(6) = -4: dataValue(6) = "AND>"
gpCode(7) = -4: dataValue(7) = "OR>"
     dxfcode = gpCode: dxfdata = dataValue
     setName = "$PolygonSelect$"

     With ThisDrawing
          Set setColl = .SelectionSets
          For Each setObj In setColl
               If setObj.Name = setName Then
                    .SelectionSets.Item(setName).Delete
                    Exit For
               End If
          Next
          Set setObj = .SelectionSets.Add(setName)
     End With
     selMod = acSelectionSetWindowPolygon
     '\\' change mode to your suit
     setObj.SelectByPolygon selMod, ptArr, dxfcode, dxfdata
     setObj.Highlight True
     MsgBox "Selected: " & CStr(setObj.Count) & " objects" & vbCr & "Do your rest work further"
     


Err_Control:
If Err.Number <> 0 Then
     MsgBox Err.Description
End If
End Sub


Public Function ConvTo3dPoints(objCoors As Variant, dblElv As Double) As Variant
     Dim i As Long, j As Long
     Dim convPts() As Variant

     j = 0
     For i = LBound(objCoors) To UBound(objCoors) Step 2
          ReDim Preserve convPts(0 To j)
          convPts(j) = CDbl(objCoors(i))
          ReDim Preserve convPts(0 To j + 1)
          convPts(j + 1) = CDbl(objCoors(i + 1))
          ReDim Preserve convPts(0 To j + 2)
          convPts(j + 2) = dblElv
          j = j + 3

     Next
     ConvTo3dPoints = convPts

End Function
Function IsEqual(a As Double, b As Double, fuzz As Double) As Boolean
' by Tony Tanzillo
     If Abs(a - b) <= fuzz Then
          IsEqual = True
     End If

End Function
Function IsPointsEqual(p1 As Variant, p2 As Variant, fuzz As Double) As Boolean
' by Fatty (looks ugly but works)
     Dim i As Integer
     Dim Check As Boolean

     Check = True

     If IsEqual(CDbl(p1(0)), CDbl(p2(0)), fuzz) = False Then
          Check = False
          Exit Function
     End If
     If IsEqual(CDbl(p1(1)), CDbl(p2(1)), fuzz) = False Then
          Check = False
          Exit Function
     End If
     If UBound(p1) = 2 Then
          If IsEqual(CDbl(p1(2)), CDbl(p2(2)), fuzz) = False Then
               Check = False
               Exit Function
          End If
     End If

     IsPointsEqual = Check

End Function
Function RemoveDupVexs(ByVal strArr As Variant) As Variant
     Dim clearArr() As Variant
     Dim unitStr As Variant
     Dim storeColl As New Collection
     Dim findCheck As Boolean
     Dim i, k As Long

     For i = 0 To UBound(strArr)
          For Each unitStr In storeColl
               If IsPointsEqual(unitStr, strArr(i), 0.00001) = True Then
                    findCheck = True
               End If
          Next

          If findCheck = False Then
               storeColl.Add strArr(i)
          Else
               findCheck = False
          End If
     Next
     i = storeColl.Count - 1
     ReDim clearArr(0 To i) As Variant

     For k = 0 To storeColl.Count - 1
          clearArr(k) = storeColl(k + 1)
     Next
     RemoveDupVexs = clearArr
End Function

Function FlattenArray(sourceArr As Variant) As Variant
     Dim i As Integer
     Dim j As Integer
     Dim k As Integer
     Dim varPt As Variant
     Dim outArr() As Variant
     j = 0
     For i = 0 To UBound(sourceArr)
          For k = 0 To 1
               ReDim Preserve outArr(j)
               outArr(j) = CDbl(sourceArr(i)(k))
               j = j + 1
          Next k
     Next i
     FlattenArray = outArr
End Function

~'J'~

[3wood]

Please try SMARTSEL.vlx

3wood

CAD KITS