TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ozimad on May 26, 2010, 08:11:11 AM
-
Hi!
Need help to create lisp to break objects.
White line is one i need to break around red objects.
1. Get red objects
2. Get white objects
3. Find intersection points
4. Sort intersection points to be in growing order from white line start to end.
5. Break objects between red objects. => I now the routine till now, how can i find is the the right pair of int. points to cut the white line from one red object to another.
Thanks a lot!
-
The example you have provided seems trivial. If you already have the intersection points in order then the correct points are P1-P2 then P3-P4 etc... Or is there a more complex application that will cause an exception. Unless I am misunderstanding I think you need to provide a little more information.
-
But if the start point is in the centre of red object, this mean i have have to take p1-p2 p3-p4, but if not then p2-p3 p4-5...
-
Maybe you could modify this to do what you want:
http://www.theswamp.org/index.php?topic=21324.msg258512#msg258512
-
Very nice but i did not worked on my machine :cry:
I need inverted result, i need lines in the object, not out of it.
-
End of the day and i am here. :ugly:
Need to get the points in two lists with one intersection point nad 2 intersection points =>
Still do not understand why the ipp return the results only when the result is printed in ipp function. Took it from cabs lisp :mrgreen:
(defun c:trim2 ()
;;funi
(defun ipp (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 0)
)
)
)
)
)
)
(princ)
(setq iplist nil)
)
(print iplist)
;;;ubratj potom
)
(defun ipp-corection (p / r)
(if (= (length p) 3)
(setq r p)
(princ)
)
(if (= (length p) 6)
(progn
(setq p1 (list
(car p)
(cadr p)
(caddr p)
)
)
(setq p (cdr (cdr (cdr p))))
(setq p2 (list
(car p)
(cadr p)
(caddr p)
)
)
(setq r (list p1 p2))
)
(setq r nil)
)
)
;;;voood
(setq ss1 (ssget));;;break
(setq ss2 (ssget));;;boundary
;;;rabota
(repeat (setq i1 (sslength ss1))
;;;;1
(setq e1 (vlax-ename->vla-object (ssname ss1 (setq i1 (1- i1)))))
(print i1)
(repeat (setq i2 (sslength ss2))
(print i2)
(setq pl0
(ipp-corection
(ipp e1
(vlax-ename->vla-object (ssname ss2 (setq i2 (1- i2))))
)
)
)
)
)
;;;1
)
-
Give this a shot ... it works with the example you provided.
(defun c:chopchop (/ f lyr pt pts ss x)
(vl-load-com)
(if (and (setq f (car (entsel "\nSelect fence: ")))
(setq f (vlax-ename->vla-object f))
(setq lyr (vla-get-layer f))
(setq ss (ssget '((0 . "lwpolyline,circle"))))
)
(progn ;;get intersections
(setq x
(apply 'append
(mapcar '(lambda (x) (vlax-invoke f 'intersectwith x acextendthisentity))
(vl-remove-if
'(lambda (e) (equal e f))
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
)
)
;;convert to 3d points
(while (caddr x)
(setq pts (cons (list (car x) (cadr x) (caddr x)) pts)
x (cdddr x)
)
)
;;sort the points
(setq pts (vl-sort pts (function (lambda (a b) (< (apply '+ a) (apply '+ b))))))
;;add lines
(while (setq pt (cadr pts))
(entmakex (list '(0 . "LINE") (cons 8 lyr) (cons 10 (car pts)) (cons 11 pt)))
(setq pts (cddr pts))
)
;;remove fence
(vla-delete f)
)
)
(princ)
)
-
ronjonp
Thanks for the routine!
Can you please add a filter to sort and save only the points when lines have 2 or 4 or 6 or 8..... intersection points?
I will use break to cut sections. But before i will do the sort by the length from the start of the polyline.
-
ronjonp
Love your routine...this one has found a home in my toolbox top drawer.
-
ronjonp
Love your routine...this one has found a home in my toolbox top drawer.
I keep snacks in my top drawer.
-
ronjonp
Love your routine...this one has found a home in my toolbox top drawer.
Glad you have a use for it Gary. :-)
-
ronjonp
Love your routine...this one has found a home in my toolbox top drawer.
I keep snacks in my top drawer.
I wish I had a drawer :-D
-
ronjonp
Love your routine...this one has found a home in my toolbox top drawer.
I keep snacks in my top drawer.
I wish I had a drawer :-D
Going commando today?
-
ronjonp
Love your routine...this one has found a home in my toolbox top drawer.
I keep snacks in my top drawer.
I wish I had a drawer :-D
Going commando today?
You don't wanna know :P
-
Please help me...
how can i add something like that?
(if (= 0 (rem (vl-list-length (vlax-invoke f 'intersectwith x acextendnone)) 2)))
-
Please help me...
how can i add something like that?
(if (= 0 (rem (vl-list-length (vlax-invoke f 'intersectwith x acextendnone)) 2)))
Give this a whirl :)
(defun c:chopchop (/ f lyr pt pts ss x)
(if (and (setq f (car (entsel "\nSelect fence: ")))
(setq f (vlax-ename->vla-object f))
(setq lyr (vla-get-layer f))
(setq ss (ssget '((0 . "lwpolyline,circle"))))
)
(progn ;;get intersections
(setq
x (apply
'append
(vl-remove-if-not
'(lambda (l) (zerop (rem (length l) 2)))
(mapcar '(lambda (x) (vlax-invoke f 'intersectwith x acextendthisentity))
(vl-remove-if
'(lambda (e) (equal e f))
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
)
)
)
;;convert to 3d points
(while (caddr x)
(setq pts (cons (list (car x) (cadr x) (caddr x)) pts)
x (cdddr x)
)
)
;;sort the points
(setq pts (vl-sort pts (function (lambda (a b) (< (apply '+ a) (apply '+ b))))))
;;add lines
(while (setq pt (cadr pts))
(entmakex (list '(0 . "LINE") (cons 8 lyr) (cons 10 (car pts)) (cons 11 pt)))
(setq pts (cddr pts))
)
;;remove fence
(vla-delete f)
)
)
(princ)
)
-
fantastic i am one step to the result:
Why do I get a million of points, finding all the intersection points? :lol:
(defun c:chop (/ f lyr pt pts ss x)
(vl-load-com)
(setq ss0 (ssget '((0 . "lwpolyline,circle"))))
(setq ss (ssget '((0 . "lwpolyline,circle"))))
(repeat (setq i1 (sslength ss0))
(if (setq f (vlax-ename->vla-object
(setq obj1 (ssname ss0 (setq i1 (1- i1))))
)
)
(progn
;;get intersections div 2
(setq
x
(apply
'append
(vl-remove-if-not
'(lambda (l) (zerop (rem (length l) 2)))
(mapcar
'(lambda (x)
(vlax-invoke f 'intersectwith x acextendnone)
)
(vl-remove-if
'(lambda (e) (equal e f))
(mapcar
'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
)
)
)
;;convert to 3d points
(while (caddr x)
(setq pts (cons (list (car x) (cadr x) (caddr x)) pts)
x (cdddr x)
)
)
(setq x pts)
(setq pts "1")
;;sort the points
(while (not (= x nil))
(setq pmin (car x))
(repeat (setq i (VL-LIST-LENGTH x))
(if (> (vlax-curve-getdistatpoint f pmin)
(vlax-curve-getdistatpoint
f
(setq current (nth (setq i (1- i)) x))
)
)
(setq pmin current)
;;yes
(princ)
;;no
)
)
(setq x (vl-remove pmin x))
(if (= pts "1")
(setq pts (list pmin))
(setq pts (append pts (list pmin)))
)
)
;;;;;;;;;;;;;;all points
;;get intersections
(setq x
(apply
'append
(mapcar
'(lambda (x)
(vlax-invoke f 'intersectwith x acextendnone)
)
(vl-remove-if
'(lambda (e) (equal e f))
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
)
)
;;convert to 3d points
(while (caddr x)
(setq pts1 (cons (list (car x) (cadr x) (caddr x)) pts1)
x (cdddr x)
)
)
(setq x pts1)
;;;sort point find min
(setq pmin (caar x))
(print x)
(repeat (setq i (VL-LIST-LENGTH x))
(if (> (vlax-curve-getdistatpoint f pmin)
(vlax-curve-getdistatpoint
f
(setq current (nth (setq i (1- i)) x))
)
)
(setq pmin current)
;;yes
(princ)
;;no
)
)
(print pmin)
;;;;;;situation
(if (= pmin (car pts))
(if (= pmin (vlax-curve-getstartpoint f))
;;no
;;1 p first
(progn
(setq pts (cdr pts))
)
;;yes2
(append (list (vlax-curve-getstartpoint f)) pts)
;;no2
)
(progn
(append (list pmin) pts)
)
)
;;add lines
(while (setq pt (car pts))
(setq pt2 (cadr pts))
(command "_.break" (list obj1 pt) pt2)
(setq obj1 (entlast))
(setq pts (cddr pts))
)
)
)
(princ)
)
)
[code][/code]
-
Attn: Ozimad (http://www.theswamp.org/index.php?topic=4429.0)
-
thanks lee!