明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 2082|回复: 2

[求助]请求完善下面批量交点打断程序,1、可以打断PLINE线,2、内部断线可以自动删

[复制链接]
发表于 2010-9-25 14:38 | 显示全部楼层 |阅读模式
[求助]请求完善下面批量交点打断程序,1、可以打断PLINE线,2、内部断线可以自动删除.[br]

;;;;;;;;;批量交点打断程序,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
)


发表于 2017-11-14 12:21 | 显示全部楼层
你这个程序完善了吗?
发表于 2018-1-6 22:12 | 显示全部楼层
恩 ,思路不错,我看看能不能重写
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-7-20 01:05 , Processed in 0.282064 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表