TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: trogg on July 26, 2012, 12:12:19 PM
-
After doing a search for something like this with no luck, I have just decided to ask if any knows of a routine or a better way to accomplish this.
If there is an object that has other objects that cross the original object thus creating intersections, is there an easier way to trim every other segment besides manually picking with TRIM <enter><enter>?
Thanks
~Greg
-
Just write a test routine , Must add curve is closed dealing .
(defun c:test (/ interpts en0 p0 d0 minpt maxpt con ss e pts l l1 res a b p)
;; Trim every other
;; by GSLS(SS) 2012-07-28
;; just for test in WCS
(defun interpts (e1 e2 lim / m)
(if (not
(minusp
(vlax-safearray-get-u-bound
(vlax-variant-value
(setq m (vla-IntersectWith
(vlax-ename->vla-object e1)
(vlax-ename->vla-object e2)
lim
)
)
)
1
)
)
)
((lambda (a / b r)
(repeat (/ (length a) 3)
(setq b (list (car a) (cadr a) (caddr a))
a (cdddr a)
r (cons b r)
)
)
)
(vlax-safearray->list (vlax-variant-value m))
)
)
)
(if
(and (setq
en0 (entsel "Select every other trim curve's point :")
)
(setq p0 (cadr en0))
(setq en0 (car en0))
(setq p0 (vlax-curve-getclosestpointto en0 p0))
(setq d0 (vlax-curve-getDistAtPoint en0 p0))
(not
(vla-GetBoundingBox
(vlax-ename->vla-object en0)
(quote minpt)
(quote maxpt)
)
)
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt)
)
(setq con
(list minpt
(list (car maxPt) (cadr minPt) 0.0)
maxPt
(list (car minpt) (cadr maxpt) 0.0)
)
)
(setq
ss (ssget "CP" con (list (cons 0 "*LINE,CIRCLE,ARC,ELLIPSE")))
)
(setq ss (ssdel en0 ss))
(> (sslength ss) 1)
)
(progn
(princ "\nEnter next Step ...")
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (setq pts (interpts en0 e 0))
(foreach a pts
(setq l (cons (list e (vlax-curve-getDistAtPoint en0 a)) l))
)
)
)
(setq l (vl-sort l
(function (lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
)
(while (and (setq a (car l)) (< (cadr a) d0))
(setq l1 (cons a l1)
l (cdr l)
)
)
(setq res (list (list (caar l1)
(caar l)
(vlax-curve-getPointAtDist
en0
(* 0.5 (+ (cadar l1) (cadar l)))
)
)
)
l1 (cdr l1)
l (cdr l)
)
(while (cadr l1)
(setq a (car l1)
b (cadr l1)
l1 (cddr l1)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(if l1
(setq res (cons (list (caar l1)
nil
(vlax-curve-getpointatdist
en0
(* 0.5 (cadar l1))
)
)
res
)
)
)
(while (cadr l)
(setq a (car l)
b (cadr l)
l (cddr l)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(if l
(setq res (cons (list (caar l)
nil
(vlax-curve-getpointatdist
en0
(* 0.5
(+ (cadar l)
(vlax-curve-getDistAtPoint
en0
(vlax-curve-getendpoint en0)
)
)
)
)
)
res
)
)
)
;;here must add en0 is closed determining .
;;....
(command "_.undo" "begin")
(foreach l res ;_(setq l (car res))
(if (apply 'and l)
(command "_.trim" (car l) (cadr l) "" (caddr l) "")
(if (and (car l) (caddr l))
(command "_.trim" (car l) "" (caddr l) "")
)
)
)
(command "_.undo" "end")
)
)
(princ "\n...End routine .")
(princ)
)
-
my new version
(defun c:test (/ *error* interpts en0 p0 d0 minpt
maxpt con ss e pts l l1 res a
b p _pb _err
)
;; Trim every other
;; by GSLS(SS) 2012-07-28
;; just for test in WCS
(defun interpts (e1 e2 lim / m)
(if (not
(minusp
(vlax-safearray-get-u-bound
(vlax-variant-value
(setq m (vla-IntersectWith
(vlax-ename->vla-object e1)
(vlax-ename->vla-object e2)
lim
)
)
)
1
)
)
)
((lambda (a / b r)
(repeat (/ (length a) 3)
(setq b (list (car a) (cadr a) (caddr a))
a (cdddr a)
r (cons b r)
)
)
)
(vlax-safearray->list (vlax-variant-value m))
)
)
)
(if
(and (setq
en0 (entsel "Select every other trim curve's point :")
)
(setq p0 (cadr en0))
(setq en0 (car en0))
(setq p0 (vlax-curve-getclosestpointto en0 p0))
(setq d0 (vlax-curve-getDistAtPoint en0 p0))
(not
(vla-GetBoundingBox
(vlax-ename->vla-object en0)
(quote minpt)
(quote maxpt)
)
)
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt)
)
(setq con
(list minpt
(list (car maxPt) (cadr minPt) 0.0)
maxPt
(list (car minpt) (cadr maxpt) 0.0)
)
)
(setq
ss (ssget "CP" con (list (cons 0 "*LINE,CIRCLE,ARC,ELLIPSE")))
)
(setq ss (ssdel en0 ss))
(> (sslength ss) 1)
)
(progn
(princ "\nEnter next Step ...")
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (setq pts (interpts en0 e 0))
(foreach a pts
(setq l (cons (list e (vlax-curve-getDistAtPoint en0 a)) l))
)
)
)
(setq l (vl-sort l
(function (lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
)
(while (and (setq a (car l)) (< (cadr a) d0))
(setq l1 (cons a l1)
l (cdr l)
)
)
(setq res (list (list (caar l1)
(caar l)
(vlax-curve-getPointAtDist
en0
(* 0.5 (+ (cadar l1) (cadar l)))
)
)
)
l1 (cdr l1)
l (cdr l)
)
(while (cadr l1)
(setq a (car l1)
b (cadr l1)
l1 (cddr l1)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(while (cadr l)
(setq a (car l)
b (cadr l)
l (cddr l)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(if (vlax-curve-isClosed en0)
;;add en0 is closed dealing .
(if (and l1 l)
(setq res
(cons
(list
(caar l1)
(caar l)
(vlax-curve-getclosestpointto
en0
(mapcar
(function (lambda (x)
(* x 0.5)
)
)
(mapcar (function +)
(vlax-curve-getpointatdist en0 (cadar l1))
(vlax-curve-getpointatdist en0 (cadar l))
)
)
)
)
res
)
)
)
(progn
(if l1
(setq res (cons (list (caar l1)
nil
(vlax-curve-getpointatdist
en0
(* 0.5 (cadar l1))
)
)
res
)
)
)
(if l
(setq
res (cons (list (caar l)
nil
(vlax-curve-getpointatdist
en0
(* 0.5
(+ (cadar l)
(vlax-curve-getDistAtPoint
en0
(vlax-curve-getendpoint en0)
)
)
)
)
)
res
)
)
)
)
)
;;....
(if res
(progn
(setq _err *error*)
(defun *error* (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\nerror " msg))
)
(command "_.undo" "end")
(setvar "pickbox" _pb)
(setq *error* _err)
(princ)
)
(setq _pb (getvar "pickbox")) ;_(getvar "pickstyle")
(setvar "pickbox" 2)
(command "_.undo" "begin")
(foreach l res ;_(setq l (car res)) (redraw (car l) 3) (redraw (cadr l) 3) ;_(check-pt (list (caddr l)))
(if (apply 'and l)
(command "_.trim" (car l) (cadr l) "" (caddr l) "")
(if (and (car l) (caddr l))
(command "_.trim" (car l) "" (caddr l) "")
)
)
)
(command "_.undo" "end")
(setvar "pickbox" _pb)
(setq *error* _err)
)
)
)
)
(princ "\n...End routine .")
(princ)
)
-
Thank you for writing this. I works beautifully.
I will post a screen shot later when I get home.
Thanks
~Greg
-
chlh_jd,
Thanks again.
Here is the routine applied to the drawing that I was hoping to use it on. It works great
-
chlh_jd,
Thanks again.
Here is the routine applied to the drawing that I was hoping to use it on. It works great
You're welcome ! Nice Demo .
-
Nice routine.
You inspired me to add this functionality to my old routine here http://www.theswamp.org/index.php?topic=10370.msg132035#msg132035 (http://www.theswamp.org/index.php?topic=10370.msg132035#msg132035)
New command is BreakRemove.
-
Awesome Charles!! Initially, I was actually attempting to alter your break routine to remove every other segment but failed horribly so I scoured the internet and then gave up and ended up posting the request...
Thank you for including this function.
~Greg
-
You're very welcome. I haven't done much testing with it but as you can all of the new coding
is done in the front end function. Although it did bring to light a bug when using circles so I
updated the main code as well. I'm still testing that fix.
EDIT:
I changed the latest BreakObjects2.2 again. Updated to fix a bug when closed objects are broken and
one of the break points are at the end/start point of the closed object.
-
Nice routine.
You inspired me to add this functionality to my old routine here http://www.theswamp.org/index.php?topic=10370.msg132035#msg132035 (http://www.theswamp.org/index.php?topic=10370.msg132035#msg132035)
New command is BreakRemove.
Thanks Alan , I've been using your Break Program .
-
Add ucs case , and deal Line or 2point-Polyline aligned X-Axis or Y-Axis case .
(defun c:test (/ *error* interpts en0 p0 d0 minpt
maxpt con ss e pts l l1 res a
b p _pb _err
)
;; Trim every other
;; by GSLS(SS) 2012-07-28
;; just for test in WCS
(defun interpts (e1 e2 lim / m)
(if (not
(minusp
(vlax-safearray-get-u-bound
(vlax-variant-value
(setq m (vla-IntersectWith
(vlax-ename->vla-object e1)
(vlax-ename->vla-object e2)
lim
)
)
)
1
)
)
)
((lambda (a / b r)
(repeat (/ (length a) 3)
(setq b (list (car a) (cadr a) (caddr a))
a (cdddr a)
r (cons b r)
)
)
)
(vlax-safearray->list (vlax-variant-value m))
)
)
)
(if
(and (setq
en0 (entsel "\nSelect every other trim curve's point :")
)
(setq p0 (cadr en0))
(setq en0 (car en0))
(setq p0 (vlax-curve-getclosestpointto en0 p0))
(setq d0 (vlax-curve-getDistAtPoint en0 p0))
(not
(vla-GetBoundingBox
(vlax-ename->vla-object en0)
(quote minpt)
(quote maxpt)
)
)
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt))
(if (or (equal (car minpt) (car maxpt) 1e-6)
(equal (cadr minpt) (cadr maxpt) 1e-6)
);_deal line alinged X-Axis or Y-Axis CASE
(setq ss (ssget "_F"
(list (trans minpt 0 1) (trans maxpt 0 1))
(list (cons 0 "*LINE,CIRCLE,ARC,ELLIPSE"))
)
)
(progn
(setq con
(list minpt
(list (car maxPt) (cadr minPt) 0.0)
maxPt
(list (car minpt) (cadr maxpt) 0.0)
)
)
;; add ucs case
(if (= (getvar "WORLDUCS") 0)
(setq con (mapcar (function (lambda (x)
(trans x 0 1)
)
)
con
)
)
) ;_UCS CASE
(setq
ss (ssget "CP"
con
(list (cons 0 "*LINE,CIRCLE,ARC,ELLIPSE"))
)
)
)
)
(setq ss (ssdel en0 ss))
(> (sslength ss) 1)
)
(progn
(princ "\nEnter next Step ...")
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (setq pts (interpts en0 e 0))
(foreach a pts
(setq l (cons (list e (vlax-curve-getDistAtPoint en0 a)) l))
)
)
)
(setq l (vl-sort l
(function (lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
)
(while (and (setq a (car l)) (< (cadr a) d0))
(setq l1 (cons a l1)
l (cdr l)
)
)
(setq res (list (list (caar l1)
(caar l)
(vlax-curve-getPointAtDist
en0
(* 0.5 (+ (cadar l1) (cadar l)))
)
)
)
l1 (cdr l1)
l (cdr l)
)
(while (cadr l1)
(setq a (car l1)
b (cadr l1)
l1 (cddr l1)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(while (cadr l)
(setq a (car l)
b (cadr l)
l (cddr l)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(if (vlax-curve-isClosed en0)
;;add en0 is closed dealing .
(if (and l1 l)
(setq res
(cons
(list
(caar l1)
(caar l)
(vlax-curve-getclosestpointto
en0
(mapcar
(function (lambda (x)
(* x 0.5)
)
)
(mapcar (function +)
(vlax-curve-getpointatdist en0 (cadar l1))
(vlax-curve-getpointatdist en0 (cadar l))
)
)
)
)
res
)
)
)
(progn
(if l1
(setq res (cons (list (caar l1)
nil
(vlax-curve-getpointatdist
en0
(* 0.5 (cadar l1))
)
)
res
)
)
)
(if l
(setq
res (cons (list (caar l)
nil
(vlax-curve-getpointatdist
en0
(* 0.5
(+ (cadar l)
(vlax-curve-getDistAtPoint
en0
(vlax-curve-getendpoint en0)
)
)
)
)
)
res
)
)
)
)
)
;;....
(if res
(progn
(setq _err *error*
_pb (getvar "pickbox")
)
(defun *error* (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\nerror " msg))
)
(command "_.undo" "end")
(setvar "pickbox" _pb)
(setq *error* _err)
(princ)
)
(setvar "pickbox" 2)
(command "_.undo" "begin")
(foreach l res
(if (apply 'and l)
(command "_.trim"
(car l)
(cadr l)
""
(trans (caddr l) 0 1);_add usc case
""
)
(if (and (car l) (caddr l))
(command "_.trim" (car l) "" (trans (caddr l) 0 1) "")
)
)
)
(command "_.undo" "end")
(setvar "pickbox" _pb)
(setq *error* _err)
)
)
)
)
(princ "\n...End routine .")
(princ)
)