[求助]请求完善下面批量交点打断程序，1、可以打断PLINE线，2、内部断线可以自动删
[求助]请求完善下面批量交点打断程序，1、可以打断PLINE线，2、内部断线可以自动删除.<div class="cnt" id="blog_text"><p><font face="宋体" color="#0000ff" size="1">;;;;;;;;;批量交点打断程序,by:fools<br/>;;支持line arc circle ELLIPSE<br/>(defun c:MB (/ elist ssg n t0)<br/>(VL-LOAD-COM)<br/>(prompt "\n支持line arc circle ELLIPSE!")<br/>(setq t0 (xdl-getutime))<br/>(if (setq ssg (ssget '((0 . "line,arc,circle,ellipse"))))<br/> (vlax-for obj (vla-get-activeselectionset<br/> (vla-get-activedocument (vlax-get-acad-object))<br/> )<br/> (setq elist (cons obj elist)) ; ssg->elist<br/> )<br/>)<br/>(DoEntMake (InterSort (ssinter elist)))<br/>(princ (strcat "\n*****找到交点"<br/> (itoa n)<br/> "个，交点断开操作共耗时"<br/> (rtos (- (xdl-getutime) t0) 2 3)<br/> "秒。*****"<br/>)<br/>)<br/>(princ)<br/>(princ)<br/>)<br/>;;求交点集函数－nth<br/>;;经过测试，nth函数仅比assoc函数快一点点。<br/>;;故此函数也可取消i，j变量，直接使用assoc函数<br/>(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j)<br/>(setq outlst (mapcar 'list el)<br/>i -1 ;obj1位置指针 <br/>n 0 ;交点数计数器<br/>)<br/>(while el<br/> (setq obj1 (car el)<br/> list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表<br/> el (cdr el)<br/> el1 el<br/> j i ;obj2位置指针<br/> )<br/> (while el1<br/> (setq obj2 (car el1)<br/> el1 (cdr el1)<br/> j (1+ j)<br/> )<br/> ;;取交点<br/> (if (and (setq ipts (vla-intersectwith obj1 obj2 0))<br/> (setq ipts (vlax-variant-value ipts))<br/> (> (vlax-safearray-get-u-bound ipts 1) 0)</font></p>
<p><font face="宋体" color="#0000ff" size="1"> )<br/>(progn<br/> (setq ipts (vlax-safearray->list ipts)<br/> pts '() ;obj1,obj2交点临时列表变量<br/> )<br/> (while (> (length ipts) 0)<br/> (setq pts (cons (list (car ipts)<br/> (cadr ipts)<br/> (caddr ipts)<br/> )<br/> pts<br/> )<br/> ipts (cdddr ipts)<br/> )<br/> )<br/> (setq list1 (append list1 pts)<br/> ;存obj1交点表，循环结束后再更新<br/> n (+ n (length pts)) ;交点计数累加<br/> )<br/> ;;obj2的交点列表立即更新<br/> (setq<br/> outlst (subst (append (nth j outlst) pts)<br/> (nth j outlst)<br/> outlst<br/> )<br/> )<br/>)<br/> )<br/> )<br/> ;;当obj1存在交点，且非封闭曲线，添加两端点<br/> (if (and (cdr list1) (not (vlax-curve-isClosed obj1)))<br/> (setq list1 (append list1<br/> (list (vlax-curve-getEndPoint obj1))<br/> (list (vlax-curve-getStartPoint obj1))<br/> )<br/> )<br/> )<br/> (setq outlst (subst list1 (nth i outlst) outlst))<br/> ;更新obj1交点列表<br/>)<br/>outlst<br/>)</font></p>
<p><font face="宋体" color="#0000ff" size="1">;;点集排序及删除重复点函数<br/>(defun InterSort (el / obj1 pts plst outlst)<br/>(setq outlst '()) ;empty list<br/>(foreach item el<br/> (setq obj1 (car item)<br/> pts (cdr item)<br/> plst '() ;empty list<br/> )<br/> (if pts ;若无交点，则不修改该实体<br/> (progn<br/>;;交点排序，列表为逆序<br/>(setq<br/> pts (vl-sort<br/> pts<br/> (function (lambda (p1 p2)<br/> (< (vlax-curve-getParamAtPoint obj1 p1)<br/> (vlax-curve-getParamAtPoint obj1 p2)<br/> )<br/> )<br/> )<br/> )<br/>)<br/>;;剔除重复点并将列表顺序转正<br/>(foreach p pts<br/> (if plst<br/> (if (not (equal p (car plst) 0.00001))<br/> (setq plst (cons p plst))<br/> )<br/> (setq plst (cons p plst))<br/> )<br/>)<br/>;;闭合曲线需再添加首个交点以使新实体完全封闭<br/>(if (vlax-curve-isClosed obj1)<br/> (setq plst (cons (last plst) plst))<br/>)<br/>(setq plst (cons (vlax-vla-object->ename obj1) plst)<br/> outlst (cons plst outlst)<br/>)</font></p>
<p><font face="宋体" color="#0000ff" size="1"> )<br/> )<br/>)<br/>outlst<br/>)</font></p>
<p><font face="宋体" color="#0000ff" size="1">;;调用entmake生成新实体<br/>(defun DoEntMake (el / obj objlst objname objcen objratio objaxis)<br/>(foreach e el<br/> (setq obj (car e)<br/> objlst (entget obj)<br/> objlst (vl-remove (assoc -1 objlst) objlst) ;去除图元名<br/> objlst (vl-remove (assoc 330 objlst) objlst) ;去除id<br/> objlst (vl-remove (assoc 5 objlst) objlst) ;去除句柄<br/> objname (cdr (assoc 0 objlst))<br/> )<br/> (cond<br/> ((= objname "LINE")<br/> (repeat (- (length e) 2)<br/>(setq e (cdr e))<br/>(setq<br/> objlst (subst (cons 10 (car e)) (assoc 10 objlst) objlst)<br/>)<br/>(setq objlst<br/> (subst (cons 11 (cadr e)) (assoc 11 objlst) objlst)<br/>)<br/>(entmake objlst)<br/> )<br/> (entdel obj)<br/> )<br/> ((= objname "CIRCLE")<br/> (setq objcen (cdr (assoc 10 objlst)))<br/> (setq objlst (subst (cons 0 "ARC") (assoc 0 objlst) objlst))<br/> (setq objlst (append objlst<br/> (list (cons 100 "AcDbArc")<br/> (cons 50 0.0)<br/> (cons 51 0.0)<br/> )<br/> )<br/> )<br/> (repeat (- (length e) 2)<br/>(setq e (cdr e))<br/>(setq objlst (subst (cons 50 (angle objcen (cadr e)))<br/> (assoc 50 objlst)<br/> objlst<br/> )<br/>)<br/>(setq objlst (subst (cons 51 (angle objcen (car e)))<br/> (assoc 51 objlst)<br/> objlst<br/> )<br/>)<br/>(entmake objlst)<br/> )<br/> (entdel obj)<br/> )<br/> ((= objname "ARC")<br/> (setq objcen (cdr (assoc 10 objlst)))<br/> (repeat (- (length e) 2)<br/>(setq e (cdr e))<br/>(setq objlst (subst (cons 50 (angle objcen (cadr e)))<br/> (assoc 50 objlst)<br/> objlst<br/> )<br/>)<br/>(setq objlst (subst (cons 51 (angle objcen (car e)))<br/> (assoc 51 objlst)<br/> objlst<br/> )<br/>)<br/>(entmake objlst)<br/> )<br/> (entdel obj)<br/> )<br/> ((= objname "ELLIPSE")<br/> ;;椭圆圆心<br/> (setq objcen (cdr (assoc 10 objlst)))<br/> ;;相对于中心的长轴矢量<br/> (setq objaxis (cdr (assoc 11 objlst)))<br/> ;;短轴与长轴的比例<br/> (setq objratio (cdr (assoc 40 objlst)))<br/> (repeat (- (length e) 2)<br/>(setq e (cdr e))<br/>(setq objlst<br/> (subst<br/> (cons 41<br/> (pt->param (cadr e) objcen objaxis objratio)<br/> )<br/> (assoc 41 objlst)<br/> objlst<br/> )<br/>)<br/>(setq objlst<br/> (subst<br/> (cons 42<br/> (pt->param (car e) objcen objaxis objratio)<br/> )<br/> (assoc 42 objlst)<br/> objlst<br/> )<br/>)<br/>(entmake objlst)<br/> )<br/> (entdel obj)<br/> )<br/> )<br/>)<br/>)</font></p>
<p><font face="宋体" color="#0000ff" size="1">;;计算耗时<br/>(defun xdl-getutime ()<br/>(* 86400 (getvar "tdusrtimer"))<br/>)</font></p>
<p><font face="宋体" color="#0000ff" size="1">;;求椭圆曲线参数<br/>(defun pt->param (pt cen axis ratio / ang param)<br/>(setq ang (- (angle cen pt) (angle '(0. 0. 0.) axis)))<br/>(cond ((= (cos ang) 0.0) ;防止分母cos为零出错<br/>(if (> (sin ang) 0.0)<br/> (setq param (* 0.5 PI))<br/> (setq param (* 1.5 PI))<br/>)<br/>)<br/>((= (sin ang) 0.0)<br/>(if (> (cos ang) 0.0)<br/> (setq param 0.0)<br/> (setq param PI)<br/>)<br/>)<br/>(T<br/>(setq param (atan (/ (sin ang) (* (cos ang) ratio))))<br/>(if (< (cos ang) 0.0)<br/> (setq param (+ pi param))<br/>)<br/>)<br/>)<br/>param<br/>)</font></p></div><br/> 你这个程序完善了吗？ 恩 ，思路不错，我看看能不能重写
页:
[1]