CAD中一次性把所有相交点都打断的程序LISP程序，谢谢，我的邮箱是313013264@qq.com，不胜感激~
发布网友
发布时间：2022-05-30 21:02
共2个回答
热心网友
时间：2023-11-18 04:01
(defun c:MBB (/ elist ssg n t0)
(VL-LOAD-COM)
(setq t0 (xdl-getutime))
(if (setq ssg (ssget '((0 . "line,arc,circle,ellipse"))))
(vlax-for obj (vla-get-activeselectionset
(vla-get-activedocument (vlax-get-acad-object))
)
(setq elist (cons obj elist)) ; ssg->elist
)
)
(DoEntMake (InterSort (ssinter elist)))
(princ (strcat "\n*****找到交点"
(itoa n)
"个，交点断开操作共耗时"
(rtos (- (xdl-getutime) t0) 2 3)
"秒。*****"
)
)
(princ)
)
;;求交点集函数－nth
;;经过测试，nth函数仅比assoc函数快一点点。
;;故此函数也可取消i，j变量，直接使用assoc函数
(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j)
(setq outlst (mapcar 'list el)
i -1 ;obj1位置指针
n 0 ;交点数计数器
)
(while el
(setq obj1 (car el)
list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表
el (cdr el)
el1 el
j i ;obj2位置指针
)
(while el1
(setq obj2 (car el1)
el1 (cdr el1)
j (1+ j)
)
;;取交点
(if (and (setq ipts (vla-intersectwith obj1 obj2 0))
(setq ipts (vlax-variant-value ipts))
(> (vlax-safearray-get-u-bound ipts 1) 0)
)
(progn
(setq ipts (vlax-safearray->list ipts)
pts '() ;obj1,obj2交点临时列表变量
)
(while (> (length ipts) 0)
(setq pts (cons (list (car ipts)
(cadr ipts)
(caddr ipts)
)
pts
)
ipts (cdddr ipts)
)
)
(setq list1 (append list1 pts) ;存obj1交点表，循环结束后再更新
n (+ n (length pts)) ;交点计数累加
)
;;obj2的交点列表立即更新
(setq
outlst (subst (append (nth j outlst) pts)
(nth j outlst)
outlst
)
)
)
)
)
;;当obj1存在交点，且非封闭曲线，添加两端点
(if (and (cdr list1) (not (vlax-curve-isClosed obj1)))
(setq list1 (append list1
(list (vlax-curve-getEndPoint obj1))
(list (vlax-curve-getStartPoint obj1))
)
)
)
(setq outlst (subst list1 (nth i outlst) outlst)) ;更新obj1交点列表
)
outlst
)
;;点集排序及删除重复点函数
(defun InterSort (el / obj1 pts plst outlst)
(setq outlst '()) ;empty list
(foreach item el
(setq obj1 (car item)
pts (cdr item)
plst '() ;empty list
)
(if pts ;若无交点，则不修改该实体
(progn
;;交点排序，列表为逆序
(setq
pts (vl-sort
pts
(function (lambda (p1 p2)
(< (vlax-curve-getParamAtPoint obj1 p1)
(vlax-curve-getParamAtPoint obj1 p2)
)
)
)
)
)
;;剔除重复点并将列表顺序转正
(foreach p pts
(if plst
(if (not (equal p (car plst) 0.00001))
(setq plst (cons p plst))
)
(setq plst (cons p plst))
)
)
;;闭合曲线需再添加首个交点以使新实体完全封闭
(if (vlax-curve-isClosed obj1)
(setq plst (cons (last plst) plst))
)
(setq plst (cons (vlax-vla-object->ename obj1) plst)
outlst (cons plst outlst)
)
)
)
)
outlst
)
;;调用entmake生成新实体
(defun DoEntMake (el / obj objlst objname objcen objratio objaxis)
(foreach e el
(setq obj (car e)
objlst (entget obj)
objlst (vl-remove (assoc -1 objlst) objlst) ;去除图元名
objlst (vl-remove (assoc 330 objlst) objlst) ;去除id
objlst (vl-remove (assoc 5 objlst) objlst) ;去除句柄
objname (cdr (assoc 0 objlst))
)
(cond
((= objname "LINE")
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 10 (car e)) (assoc 10 objlst) objlst))
(setq objlst (subst (cons 11 (cadr e)) (assoc 11 objlst) objlst))
(entmake objlst)
)
(entdel obj)
)
((= objname "CIRCLE")
(setq objcen (cdr (assoc 10 objlst)))
(setq objlst (subst (cons 0 "ARC") (assoc 0 objlst) objlst))
(setq objlst (append objlst
(list (cons 100 "AcDbArc")
(cons 50 0.0)
(cons 51 0.0)
)
)
)
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 50 (angle objcen (cadr e)))
(assoc 50 objlst)
objlst
)
)
(setq objlst (subst (cons 51 (angle objcen (car e)))
(assoc 51 objlst)
objlst
)
)
(entmake objlst)
)
(entdel obj)
)
((= objname "ARC")
(setq objcen (cdr (assoc 10 objlst)))
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 50 (angle objcen (cadr e)))
(assoc 50 objlst)
objlst
)
)
(setq objlst (subst (cons 51 (angle objcen (car e)))
(assoc 51 objlst)
objlst
)
)
(entmake objlst)
)
(entdel obj)
)
((= objname "ELLIPSE")
;;椭圆圆心
(setq objcen (cdr (assoc 10 objlst)))
;;相对于中心的长轴矢量
(setq objaxis (cdr (assoc 11 objlst)))
;;短轴与长轴的比例
(setq objratio (cdr (assoc 40 objlst)))
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 41 (pt->param (cadr e) objcen objaxis objratio))
(assoc 41 objlst)
objlst
)
)
(setq objlst (subst (cons 42 (pt->param (car e) objcen objaxis objratio))
(assoc 42 objlst)
objlst
)
)
(entmake objlst)
)
(entdel obj)
)
)
)
)
;;计算耗时
(defun xdl-getutime ()
(* 86400 (getvar "tsrtimer"))
)
;;求椭圆曲线参数
(defun pt->param (pt cen axis ratio / ang param)
(setq ang (- (angle cen pt) (angle '(0. 0. 0.) axis)))
(cond ((= (cos ang) 0.0) ;防止分母cos为零出错
(if (> (sin ang) 0.0)
(setq param (* 0.5 PI))
(setq param (* 1.5 PI))
)
)
((= (sin ang) 0.0)
(if (> (cos ang) 0.0)
(setq param 0.0)
(setq param PI)
)
)
(T
(setq param (atan (/ (sin ang) (* (cos ang) ratio))))
(if (< (cos ang) 0.0)
(setq param (+ pi param))
)
)
)
param
)
(princ)
这个你看下
热心网友
时间：2023-11-18 04:02
