LISP for Intersection Clean Up

[zorroxxxx]

Hi,

Does anyone have a LISP or Script that will clean up intersections? Both linear and radius intersections. I have been constantly trimming and after a few hundred thousand clicks, I figure there has to be an easier way. I've also have tried using BPOLY command but it creates polylines on top of existing lines, which I then have to delete. I am just learning LISP so I'm not sure how to conquer this problem.

I have attached a .BMP file which shows exactly what I'm looking for.

I run Vanilla ACAD 2002

Any help will be greatly appreciated

Gary

[mjfarrell]

Take a look here:http://www.cadresource.com/library/lispbc.html

[zorroxxxx]

Take a look here:http://www.cadresource.com/library/lispbc.html


Hi Michael,

Your link went to the B-C section of the site. Did you have a specific file in mind? I browsed the section and did not see anything that would work. Is there one there that can be modified to do what I need?

Thanks in advance,

Gary

[sinc]

I've wanted something similar in the past, so I figured I'd have a go at it. This is my first attempt at using the ActiveX interface, so some things might have been accomplished more easily in another way, but this works.

It lets you select a set of objects (any drawing objects should work, although results are unpredictable for circles). Any objects that intersect two and only two of the other objects in the selection set will be broken between the intersection points. If a given object has more than two intersections, then the code wouldn't know which segments to remove. It would need to be extended to allow the user to specify which segments to remove, possibly by selecting inside the desired intersections as you proposed, although I haven't yet figured out the best way of going about it. Feel free to tackle it yourself.

The code loops until you hit enter or right-click without selecting any objects.


;; takes a selection set, and trims the gap between intersection points for
;; all objects that intersect two and only two of the other objects in the set
;; Richard Sincovec, July 11 2004

(vl-load-com)
(defun c:itrim (/ acadObj doc ssets ss count err i j items item intxlist
intitem)
(setq acadObj (vlax-get-acad-object)
doc (vla-get-activeDocument acadObj)
ssets (vla-get-selectionSets doc)
)
(setq err (vl-catch-all-apply
(function
(lambda ()
(setq ss (vla-add ssets "ZYZ_ITRIM"))
) ;lambda
) ;function
) ;vl-catch-all-apply
) ;setq
(if (vl-catch-all-error-p err)
;; error is probably "ss already exists"
;; it shouldn't yet, but use it if it does
(setq ss (vla-item ssets "ZYZ_ITRIM"))
) ;if
(while ; (MAIN)
(progn
(vla-clear ss)
(vla-selectOnScreen ss)
(setq count (vla-get-count ss))
(/= count 0)
) ;progn
(setq i count
items nil
) ;setq
(while (/= i 0)
(setq i (1- i)
item (vla-item ss i)
j count
intxlist nil
) ;setq
(while (/= j 0)
(setq j (1- j)
intitem (vla-item ss j)
) ;setq
;; I kept getting an exception on vlax-safearray->list
;; if intersectWith found no points, and couldn't figure
;; out offhand how to stop getting it, so I decided to catch
;; and ignore it instead
(if (/= (vla-get-handle item) (vla-get-handle intitem))
(vl-catch-all-apply
(function
(lambda ()
(setq
intx (vlax-safearray->list
(vlax-variant-value
(vla-IntersectWith
item
intitem
acExtendNone
)
)
)
intxlist (append intxlist (list intx))
) ;setq
) ;lambda
) ;function
) ;vl-catch-all-apply
) ;if
) ;while j
;; if we found two and only two intersections, store the entity for breaking
;; if we break it now, it will confuse the rest of the intersection checking
(if (= (length intxlist) 2)
(setq
items (append
items
(list (cons (vlax-vla-object->ename item) intxlist))
)
)
) ;if
) ;while i
;; break the items
(foreach item items
(command "break"
(list (car item) (cadr item))
(caddr item)
)
) ;foreach
) ;while (MAIN)
(vla-delete ss)
(princ)
) ;defun

[peter]

here is a little routine that I cooked up. Just select the 4 lines to trim and it should clip them the way you want.

Peter Jamtgaard


(defun C:TRIMIT3 (/ intCount
lstPairs3
lstPoints3
lstPoints4
lstObjects
lstObjects2
lstObjects3
ssSelections )

(setq ssSelections (ssget (list (cons 0 "*line,arc"))))
(repeat (setq intCount (sslength ssSelections))
(setq intCount (1- intCount)
lstObjects (cons (vlax-ename->vla-object (ssname ssSelections intCount))
lstObjects
)
)
)
(repeat (setq intCount (length lstObjects))
(setq intCount (1- intCount)
objSelection (nth intCount lstObjects)
lstPairs3 nil
)
(repeat (setq intCount2 (length (setq lstObjects2 (vl-remove objSelection lstObjects))))
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda (X Y)
(setq varPOint (vla-intersectwith X Y 0))
)
(list objSelection (nth (1- intCount2) lstObjects2))
)
)
)
(progn
(if (safearray-value (variant-value varPoint))
(progn
(setq lstPoint (vlax-safearray->list (variant-value varPoint))
lstPairs3 (cons (cons (vlax-curve-getparamatpoint objSelection lstPoint)
lstPoint
)
lstPairs3
)
)
)
)
)
)

(setq intCount2 (1- intCount2))
)
(if lstPairs3
(progn
(setq lstPairs3 (sortList lstPairs3 0)
lstPoints3 (mapcar 'cdr lstPairs3)

)
)
)
(setq lstPoints4 (cons (cons objSelection (reverse lstPoints3))
lstPoints4
)
lstPoints3 nil
lstPairs nil
)
)
(foreach lstN lstPoints4
(setq objSelection (car lstN)
lstN (cdr lstN)
)
(repeat (/ (length lstN) 2)
(vl-cmdf "break"
(vlax-vla-object->ename objSelection)
"F"
(car lstN)
(cadr lstN)
)
(setq lstN (cddr lstN))
)
)
)
(defun SortList (lstOfLists intItem)
(vl-sort lstOfLists '(lambda (n1 n2) (<= (nth intItem n1) (nth intItem n2))))
)

[zorroxxxx]

Thanks to all for solving my problem.

Richards' file worked great for individual intersections and Peter's file worked for individual and multiple intersections. Thanks to Michael for a link to a good LISP resource.

As a beginner in the world of LISP maybe someday I'll be able to help someone as you have.

THANKS!!!

Gary

[zorroxxxx]

Peter,

Your file only seems to work in Acad 2004. I emailed it to my work and could not get it to run on Acad 2002.

Is there a way to modify your file to get it working in 2002?

Thanks in advance,

Gary

[jwanstaett]

add

(vl-load-com)
to the start of peter file as richards did and it will work in in 2002

[Lemons]

I just use a fillet crossing with a zero radius to do this:

(defun c:fc () (command "undo" "m") (command "fillet" "R" "0") (command "fillet" "c"))

[sinc]

If you try the routines we posted, you'll see they do something different. They actually do the equivalent of breaking four lines and then running your fc function four times... (in the simplest case, anyway...)

[zorroxxxx]

Thanks JWANSTAETT,

That did the trick!

Once again I want to thank everyone for their help in solving my problem.

Gary

[BCrouse]

Will this work with wall styles?

Thank you

Brad

[jwf]

This one might come in useful as well.
(DEFUN C:inter ()
;this section sets some preliminary variables for the program
(Setvar "CMDECHO" 0)
(setq ds (getvar "dimscale"))
(setq zdist (/ ds 3))
(setq counter 0)
(setq count2 1)
(setq ccount 0
lcount 0
)
(Setq pickold (getvar "pickbox"))
(setvar "pickbox" 7)
(prompt
"This program will explode all polylines to determine if individual line segments"
)
(terpri)
(prompt
"intersect other drawing objects. Wait 3 seconds or press esc now to exit"
)
(terpri)
(command "DELAY" "3000")
;This section makes a selection set of all poly lines and explodes them one by one
(setq sspl (ssget "X" '((0 . "LWPOLYLINE"))))
(if (/= sspl nil)
(setq sspllen (sslength sspl))
()
)
(setq pl 0)
(while (< pl sspllen)
(setq obj (ssname sspl pl))
(command "EXPLODE" obj "")
(setq pl (+ pl 1))
) ;while
;This section makes a selection set of all lines in the object database.
(setq ssl (ssget "X" '((0 . "LINE"))))
(setq sslen (sslength ssl))
;this section finds intersection points of lines and asks the user to break one
(while (< counter sslen)
(setq obja (ssname ssl counter))
(setq objadata (entget obja))
(setq astart (cdr (assoc 10 objadata)))
(setq aend (cdr (assoc 11 objadata)))
(while (< count2 sslen)
(setq objb (ssname ssl count2))
(setq objbdata (entget objb))
(setq bstart (cdr (assoc 10 objbdata)))
(setq bend (cdr (assoc 11 objbdata)))
(setq abint (inters astart aend bstart bend))
(if (or (equal bstart aend) (equal bend astart))
(setq abint nil)
()
) ;if
(if (/= abint nil)
(progn
(SETQ ZPOINT1 (POLAR ABINT 0.523 ZDIST))
(SETQ ZPOINT2 (POLAR ABINT 3.66 ZDIST))
(COMMAND "ZOOM" "WINDOW" ZPOINT1 ZPOINT2)
(setq BDIST 0.0443)
(setq OS (getvar "osmode"))
(setvar "osmode" 0)
(initget 1 "Yes No")
(setq test (getkword
"Would you like to break something here (Y/N)?"
)
)
(if (= test "Yes")
(progn
(setq ENT1
(car (entsel "\nSelect crossing line to break: "))
)
(setq LINE1 (entget ENT1))
(setq LN (cdr (assoc 8 LINE1)))
(setq P1 (cdr (assoc 10 LINE1)))
(setq P2 (cdr (assoc 11 LINE1)))
(setq AN (angle P1 P2))
(setq ENT2 (car (entsel "\nSelect line to cross over: ")))
(terpri)
(setq LINE2 (entget ENT2))
(setq P3 (cdr (assoc 10 LINE2)))
(setq P4 (cdr (assoc 11 LINE2)))
(setq IN (inters P1 P2 P3 P4))
(setq BPT1 (polar IN AN (* BDIST (getvar "dimscale"))))
(setq BPT2
(polar IN (+ AN pi) (* BDIST (getvar "dimscale")))
)
(command "break" ENT1 BPT1 BPT2)
(setvar "osmode" OS)
(Prompt "Pausing to show you your selection")
(terpri)
(command "DELAY" "1000")
) ;progn
) ;if
) ;progn
()
) ;if
(setq count2 (+ count2 1))
) ;while
(setq counter (+ counter 1))
(setq count2 (+ counter 1))
) ;while
(setvar "pickbox" pickold)
(Prompt
"Please run inters again to ensure all intersecting lines have been broken"
)
(terpri)
) ;defun

[kparchitect]

I just use a fillet crossing with a zero radius to do this:

(defun c:fc () (command "undo" "m") (command "fillet" "R" "0") (command "fillet" "c"))

I'm updating my 2005 "acad.mnu" and "adt.mnu" for buttons on my Calcomp digitizer puck. All of them work EXCEPT the fillet command. In previous versions of AutoCad, the following worked (for my button #5):

[5 Fillet]*^c^c$s=x $s=fillet fillet

This doesn't work. The comand line shows jibberish and scrolls.

Here's the code for my button #6. IT works. I tried adding "auto" to the end of #5. No good.
[6 trim]*^c^c$s=x $s=trim trim auto

Can anyone help me with a direction for this problem?????
Thanks!