断面线添加顶点--多段线添加顶点

77077 · 发表于 2015-7-13 01:28:51

多段线添加顶点

(defun C:tt (/ en dxfold dxf10 dxf90 pt ptlst dxfnew)
(princ "\n 断面线添加顶点")
(if (and (setq en (car (entsel "\n 选择设计断面线:")))
(setq dxfold (entget EN))
(= (cdr(assoc 0 dxfold)) "LWPOLYLINE")
)
(progn
(setq dxf10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxfold)
dxf90 (1+ (cdr(assoc 90 dxfold)))
dxfold (vl-remove-if '(lambda (x) (or (= (car x) 10) (= (car x) 40) (= (car x) 41) (= (car x) 42)))dxfold)
dxfold (subst (cons 90 dxf90) (assoc 90 dxfold) dxfold)
)
(while (= (car (setq grpt (grread nil 5 0))) 5)
(setq pt (cons 10 (cadr grpt))
ptlst (cons pt dxf10)
ptlst (vl-sort ptlst '(lambda(a b)(< (cadr a) (cadr b))))
dxfnew (append dxfold ptlst)
)
(entmod dxfnew)
);while
);progn
(alert "错误，所选不符合要求")
);if
)

(defun C:tt (/ en dxfold dxf10 dxf90 pt ptlst dxfnew) 
  (princ "\n 断面线添加顶点") 
  (if (and (setq en (car (entsel "\n 选择设计断面线:"))) 
         (setq dxfold (entget EN)) 
         (= (cdr(assoc 0 dxfold)) "LWPOLYLINE") 
       ) 
  (progn 
    (setq dxf10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxfold) 
          dxf90 (1+ (cdr(assoc 90 dxfold))) 
          dxfold (vl-remove-if '(lambda (x) (or (= (car x) 10) (= (car x) 40) (= (car x) 41) (= (car x) 42)))dxfold) 
          dxfold (subst (cons 90 dxf90) (assoc 90 dxfold) dxfold) 
         ) 
    (while (= (car (setq grpt (grread nil 5 0))) 5) 
       (setq pt (cons 10 (cadr grpt)) 
             ptlst (cons pt dxf10) 
             ptlst (vl-sort ptlst '(lambda(a b)(< (cadr a) (cadr b)))) 
             dxfnew (append dxfold ptlst) 
             ) 
       (entmod dxfnew) 
     );while 
    );progn 
    (alert "错误，所选不符合要求") 
  );if 
)

演示：

spp_wall · 发表于 2015-7-13 08:20:48

不错！！！！！！！！！！！！！！

LIULISHENG · 发表于 2018-1-2 11:53:13

效果不错哦

技术工作室 · 发表于 2022-9-8 15:00:05

效果不错，顶一个

wanhongron · 发表于 2023-6-3 17:44:43

能增加捕捉模式吗

66453250 · 发表于 2023-6-12 19:47:07

效果不错，顶一个

cchessbd · 发表于 2023-6-12 20:26:03

哦，太棒了，楼主真的是高手！！！解决了我的问题了，6666666

账号		自动登录	找回密码
密码			注册

[源码] 断面线添加顶点--多段线添加顶点

本帖子中包含更多资源

评分