[转帖]请调试，1、增加批量交点打断PLINE，2、把断开的线删除，谢谢！

cxs259

;;;;;;;;;批量交点打断程序,by:fools
;;支持line arc circle ELLIPSE
(defun c:MB (/ elist ssg n t0)
(VL-LOAD-COM)
(prompt "\n支持line arc circle ELLIPSE!")
(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)
(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 "tdusrtimer"))
)

;;求椭圆曲线参数
(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
)

894560869

meja

辛苦写这么多源码

DLSPH

尘缘一生

程序不错，支持PLINE的改进有没有？

尘缘一生

顶起来这个问题，谁能增加多段线支持？