cad批量交点打断 lisp_晓东CAD家园-论坛-A/VLISP-批量交点打断-各位有批量交点打断！！各自塞下 总有个你觉得很好 - Powered by Discuz!...

贴一个复杂的

[pcode=lisp,true](defun c:Ea:ssbrk (/                 THINKING      removedups

ybl-pts-sortoncurve               ybl-mklwpline

ybl-mkellipse ybl-mkline    ybl-mkarc

ybl-circletoarc               sstolist

lll                 ss               cset

eDoc                 n               oldos

t1                 sl

)

(defun THINKING (prmpt)

(setq n (1+ n))

(princ (strcat "\r"

(nth (rem n 4) '("|" "/" "-" "\\"))

prmpt

)

)

)

(defun removedups (lst / p pl)

(while lst

(setq p (car lst))

(if (not (equal p (car pl)))

(setq pl (cons p pl))

)

(setq lst (cdr lst))

)

(reverse pl)

)

;;端点判断

(defun ispoint (lst p1 p2)

(and (= (length pts) 2)

(or (and (equal (car pts) sp 1e-9)

(equal (cadr pts) ep 1e-9)

)

(and (equal (car pts) ep 1e-9)

(equal (cadr pts) sp 1e-9)

)

)

)

)

;;Break 去除端点

(defun removepoint (lst p1 p2)

(if        (equal (car lst) p1 1e-9)

(setq lst (cdr lst))

)

(if        (equal (last lst) p2 1e-9)

(setq lst (reverse (cdr (reverse lst))))

)

lst

)

;;交点沿曲线排升序

(defun ybl-pts-sortoncurve (e pts / pl sp ep el typ)

(if        (and (setq sp (vlax-curve-getstartpoint e)

ep (vlax-curve-getendpoint e)

)

(ispoint pts sp ep)

) ;_ startpoint and endpoint

(setq pts nil)

;;circle ellipse 不一定需要 startpoint endpoint

(progn

(if (not (vlax-curve-isclosed e))

(setq pts (cons sp (cons ep pts)))

)

(setq

pts

(removedups

(vl-sort

(mapcar '(lambda        (x)

(list        (vlax-curve-getparamatpoint

e

(vlax-curve-getclosestpointto e x)

)

x

)

)

pts

)

'(lambda (e1 e2) (< (car e1) (car e2)))

)

)

)

)

) ;_ remove startpoint

pts

)

;;断开 spline pline，闭合 spline 不能打断

(defun ybl-brkspline (lst / e pts p0 pam)

(setq e   (car lst)

pts (reverse (mapcar 'cadr

(ybl-pts-sortoncurve

e

(cdr lst)

)

)

) ;_ 逆序)

)

(if        pts

(if (and (vlax-curve-isclosed e) ;_ closed

(> (length pts) 1)

) ;_两个以上交点才断开

(progn

(setq        p0  (car pts)

pts (cdr pts)

pam (vlax-curve-getparamatpoint

e

(vlax-curve-getclosestpointto e p0)

)

)

(vl-cmdf ".break"

e

"_non"

p0

"_non"

(vlax-curve-getpointatparam e (+ pam 0.0000001))

) ;_两个交点以上先断开一个小口

(setq pts (removepoint pts sp ep))

(if pts

(foreach p pts

(vl-cmdf ".break" e p p)

)

)

)

(progn ;_ opened

(setq        pts (removepoint

pts

(vlax-curve-getstartpoint e)

(vlax-curve-getendpoint e)

)

)

(if pts

(foreach p pts

(vl-cmdf ".break" e p p)

)

)

)

)

)

)

(defun ybl-mklwpline (lst  /          e    el   pts         c70  h0   h1        pl

vn   i          vp   vvp  v         nnp  tf   p1        b

vn   vertexinfo            l         a    bugle        e

ew   few  forp fsw  spam sw   x

)

(setq e   (car lst)

el  (entget e '("*"))

c70 (cdr (assoc 70 el))

)

(if        (or (= (logand c70 4) 4) ;_