Intersecting Objects in AutoCAD

Hi, Im struggling to find an effective solution to work out what a
line intersects with. The simple solution would be to put all objects
in an array and cycle through and filter out the ones that do
intersect with it using 'intersectwith'. However I usually have 2000+
objects and I have to run this for couple of hundred lines. This
makes some very tedious code.

Can anyone think of a way I can either reduce the number of objects I
am cycling through maybe a radius search or automatically return the
objects the test line intersects without having to test each object.

Thanks.

 

I'm still a novice, I use the following procedure to select a series
of mtexts in a title block. This procedure is a complete copy and
does a little more than you may need.

I was thinking you could take your line coords and put them in the
pointsArray and get all entities that lie along each line.

I've remarked out a few lines of code which draw lines to help me see
what's happening visually.

Let me know how it goes.

bill.

Sub GetTextspec01() 'sub - select texts in title block
''''''''''''''''''''''
' plan B: get text centers based on text boxes for all texts; filter
text boxes by location; top row & left column
' of spec block to be descriptions
''''''''''''''''''''''
'title block must be same size and format as template

' select all the texts in predefined order
SendKeys Chr(27) & Chr(27), True
Dim sset As AcadSelectionSet
If ThisDrawing.SelectionSets.Count > 0 Then ' if there are sel sets,
then check them
For Each sset In ThisDrawing.SelectionSets
If sset.Name = "textmod01" Then sset.Delete: Exit For 'if the
sel set exists, delete it
Next sset
End If
Set ssetObj = ThisDrawing.SelectionSets.Add("textmod01")

' Add to the selection set all the objects that lie within a fence
Dim mode As Integer
Dim pointsArray(0 To 80) As Double ', first(0 To 2) As Double,
second(0 To 2) As Double
Dim temparray(0 To 11) As Double
Dim fadditive(0 To 2) As Double, sadd(0 To 2) As Double

'locate "DWG NO" text as reference point - it's in optical &
mechanical dwgs

Dim gpCode(0 To 4) As Integer
Dim dataValue(0 To 4) As Variant
gpCode(0) = -4: dataValue(0) = "<OR"
gpCode(1) = 0: dataValue(1) = "text"
gpCode(2) = 0: dataValue(2) = "mtext"
gpCode(3) = -4: dataValue(3) = "OR>"
gpCode(4) = 1: dataValue(4) = "*DWG*NO*"
'Dim gpCode(0) As Integer
'Dim dataValue(0) As Variant
'gpCode(0) = 1: dataValue(0) = "*BEVEL*MAX*FACE*"
Dim groupCode As Variant, dataCode As Variant, corner1(0 To 2) As
Double, corner2(0 To 2) As Double
groupCode = gpCode: dataCode = dataValue
corner1(0) = -9999: corner2(0) = 9999
corner1(1) = -9999: corner2(1) = 9999
corner1(2) = 0: corner2(2) = 0
'ThisDrawing.SendCommand (Chr$(27) & Chr$(27))
SendKeys Chr(27) & Chr(27), True
ThisDrawing.Application.ZoomExtents 'won't select items not
visible on the screen
ssetObj.Select acSelectionSetCrossing, corner1, corner2,
groupCode, dataCode

Dim coords(0 To 2) As Double, entobj3 As Object 'tempentobj As
AcadEntity
Dim minExt As Variant, maxExt As Variant
If ssetObj.Count > 0 Then
Set entobj3 = ssetObj.Item(0)
entobj3.GetBoundingBox minExt, maxExt
coords(0) = (maxExt(0) - minExt(0)) / 2 + minExt(0): coords(1)
= (maxExt(1) - minExt(1)) / 2 + minExt(1) ' calc center pt
coords(0) = coords(0) - 121.5: coords(1) = coords(1) + 15.1
'move first point for optical dwgs
Else
coords(0) = 56.1: coords(1) = 29.9
End If
ssetObj.Clear 'start with empty set

'now setup and get the texts
fadditive(0) = 0: fadditive(1) = 0: fadditive(2) = 0
sadd(0) = 9: sadd(1) = -1: sadd(2) = 0
mode = acSelectionSetCrossingPolygon
'base point is 54,30,0
pointsArray(0) = coords(0): pointsArray(1) = coords(1):
pointsArray(2) = 0 'radius 1
pointsArray(3) = coords(0): pointsArray(4) = coords(1) - 4:
pointsArray(5) = 0 'testplt tol 2
pointsArray(6) = coords(0): pointsArray(7) = coords(1) - 8:
pointsArray(8) = 0 'surf qual 3
pointsArray(9) = coords(0): pointsArray(10) = coords(1) - 12:
pointsArray(11) = 0 'c.a. 4
pointsArray(12) = coords(0): pointsArray(13) = coords(1) - 16:
pointsArray(14) = 0 'power 5
pointsArray(15) = coords(0): pointsArray(16) = coords(1) - 20:
pointsArray(17) = 0 'irreg 6
pointsArray(18) = coords(0): pointsArray(19) = coords(1) - 24:
pointsArray(20) = 0 'bevel min 7
pointsArray(21) = coords(0): pointsArray(22) = coords(1) - 28:
pointsArray(23) = 0 'bevel max 8
pointsArray(24) = coords(0) + 50: pointsArray(25) = coords(1):
pointsArray(26) = 0 'radius 9
pointsArray(27) = coords(0) + 50: pointsArray(28) = coords(1) - 4:
pointsArray(29) = 0 'testplt tol 10
pointsArray(30) = coords(0) + 50: pointsArray(31) = coords(1) - 8:
pointsArray(32) = 0 'surf qual 11
pointsArray(33) = coords(0) + 50: pointsArray(34) = coords(1) -
12: pointsArray(35) = 0 'c.a. 12
pointsArray(36) = coords(0) + 50: pointsArray(37) = coords(1) -
16: pointsArray(38) = 0 'power 13
pointsArray(39) = coords(0) + 50: pointsArray(40) = coords(1) -
20: pointsArray(41) = 0 'irreg 14
pointsArray(42) = coords(0) + 50: pointsArray(43) = coords(1) -
24: pointsArray(44) = 0 'bevel min 15
pointsArray(45) = coords(0) + 50: pointsArray(46) = coords(1) -
28: pointsArray(47) = 0 'bevel max 16
pointsArray(48) = coords(0) + 92: pointsArray(49) = coords(1) -
16.3: pointsArray(50) = 0 'efl 17
pointsArray(51) = coords(0) + 92: pointsArray(52) = coords(1) -
22.3: pointsArray(53) = 0 'blf 18
pointsArray(54) = coords(0) + 130: pointsArray(55) = coords(1) -
14.7: pointsArray(56) = 0 'dwg no 19
pointsArray(57) = coords(0) + 127: pointsArray(58) = coords(1) -
9.5: pointsArray(59) = 0 'title 20
pointsArray(60) = coords(0) + 78: pointsArray(61) = coords(1) +
7.8: pointsArray(62) = 0 'drawn by 21
pointsArray(63) = coords(0) + 78: pointsArray(64) = coords(1) +
1.9: pointsArray(65) = 0 'checked by 22
pointsArray(66) = coords(0) + 78: pointsArray(67) = coords(1) - 4:
pointsArray(68) = 0 'approved by 23
pointsArray(69) = coords(0) + 97: pointsArray(70) = coords(1) +
7.8: pointsArray(71) = 0 'drawn date 24
pointsArray(72) = coords(0) + 97: pointsArray(73) = coords(1) +
1.9: pointsArray(74) = 0 'checked date 25
pointsArray(75) = coords(0) + 97: pointsArray(76) = coords(1) - 4:
pointsArray(77) = 0 'approved date 26
pointsArray(78) = coords(0) + 205.9: pointsArray(79) = coords(1) -
14.7: pointsArray(80) = 0 'ttb revision 27

For ctr = 0 To UBound(pointsArray) Step 3
'Debug.Print ctr

For ctr1 = 0 To 2
'first(ctr1) = pointsArray(ctr + ctr1) + fadditive(ctr1)
'second(ctr1) = pointsArray(ctr + ctr1) + sadd(ctr1)
'temparray(ctr1) = pointsArray(ctr + ctr1) + fadditive(ctr1)
'temparray(ctr1 + 3) = pointsArray(ctr + ctr1) + sadd(ctr1)
temparray(0) = pointsArray(ctr + 0) + fadditive(0)
temparray(1) = pointsArray(ctr + 1) + fadditive(1)
temparray(2) = pointsArray(ctr + 2) + fadditive(2)
temparray(3) = pointsArray(ctr + 0) + fadditive(0)
temparray(4) = pointsArray(ctr + 1) + sadd(1)
temparray(5) = pointsArray(ctr + 2) + fadditive(2)
temparray(6) = pointsArray(ctr + 0) + sadd(0)
temparray(7) = pointsArray(ctr + 1) + sadd(1)
temparray(8) = pointsArray(ctr + 2) + sadd(2)
temparray(9) = pointsArray(ctr + 0) + sadd(0)
temparray(10) = pointsArray(ctr + 1) + fadditive(1)
temparray(11) = pointsArray(ctr + 2) + fadditive(2)
'Debug.Print first(ctr1)
Next ctr1

'ThisDrawing.Utility.Prompt first(0) & first(1) & first(2) &
second(0) & second(1) & second(2) & vbCrLf

ssetObj.SelectByPolygon mode, temparray
'Set lineObj = ThisDrawing.PaperSpace.AddPolyline(temparray)
If ssetObj.Count < Int(ctr / 3) Then 'if no object was found,
then substitute a line as a place holder
'ssetObj.AddItems
(ThisDrawing.PaperSpace.AddPolyline(temparray))
'Debug.Print "did not find the mtext, ctr = " & ctr
End If
Next ctr

'ssetObj.Highlight (True)
'MsgBox "selection set count: " & ssetObj.Count
'ssetObj.Delete 'TTTTTTTTTTTTTTTTt for testing only
End Sub