社区 › AutoLISP/Visual LISP 编程技术 › 消除重复的直线、圆弧

荒野孤行 发表于 2015-8-4 19:55:27

消除重复的直线、圆弧

本帖最后由 荒野孤行 于 2016-1-24 20:40 编辑

对直线的消除重线算法，会将直线转换为了f(x)=kx+b的形式；对于由多个圆心及半径相同的圆弧而组成的圆形，消除重线时会出现错误的效果（正确的应该是组成一个完整的圆），Express插件中的Overkill命令也有这个问题，这里给出的不是完善的源码，已完善的程序已集成在WDY工具箱中。


;;; *****消除重线 程序开始*****
(defun C:T1 ()
(princ
    "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！"
)
(setvar "cmdecho" 0)
(setvar "plinewid" 0)
(command "undo" "be")
(vl-load-com)
(setq ss (ssget '((0 . "ARC,LINE"))))
(princ "\n--->程序进行中，请稍后...\n")
(if ss
    (hbzhx ss)
    (progn (princ "\n提示：未选取对象.") (exit))
)
(command "undo" "e")
(alert "\n提示：消除重线完成！\n")
(princ)
)

(defun cs_pross      (to i / CS_TEXT MYI)
(setq cs_text ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>")
(setq      myi      (fix (/ (* (strlen cs_text) i) to))
      cs_text      (substr cs_text 1 myi)
)
(grtext -2 cs_text)
)
**** Hidden Message *****
(defun hb_arc (arc_list jd /)
(setq      zongshu      (length arc_list)
      xuhao      0
      i      0
)
(princ (strcat "\n共处理" (itoa zongshu) "个圆或圆弧实体"))
(grtext -1 "合并圆弧")
(while (> (length arc_list) 0)
    (setq xuhao (1+ xuhao))
    (cs_pross zongshu xuhao)
    (setq arc_a         (car arc_list)
          arc_list (cdr arc_list)
          biaoji   t
          bj         (car arc_a)
          pc         (list (cadr arc_a) (caddr arc_a))
          sangl         (cadddr arc_a)
          eangl         (nth 4 arc_a)
          ent         (last arc_a)
          lay         (cdr (assoc 8 (entget ent)))
    )
    (while (and      biaoji
                (> (length arc_list) 0)
         )
      (setq arc_b (car arc_list)
      )
      (cond
      ((and (equal bj (car arc_b) jd)
            (equal pc (list (cadr arc_b) (caddr arc_b)) jd)
            (= lay (cdr (assoc 8 (entget (last arc_b)))))
         )
         (setq sangl1 (cadddr arc_b)
               eangl1 (nth 4 arc_b)
               p5   (vl-sort (list sangl eangl sangl1 eangl1)
                               '(lambda      (e1 e2)
                                  (< e1 e2)
                              )
                      )
               sangl1 (nth (- (length p5) 2) p5)
         )
         (if (or (equal eangl sangl1 jd)
               (equal eangl1 sangl1 jd)
             )
         (progn
             (setq sangl    (car p5)
                   eangl    (last p5)
                   arc_list (cdr arc_list)
             )
             (entdel (last arc_b))
             (setq xuhao (1+ xuhao))
             (cs_pross zongshu xuhao)
             (setq i (1+ i))
         )
         (setq biaoji nil)
         )
      )
      (t (setq biaoji nil))
      )
    )
    (setq data (entget ent)
          data (subst (cons 50 sangl) (assoc 50 data) data)
          data (subst (cons 51 eangl) (assoc 51 data) data)
    )
    (entmod data)
)
(princ (strcat "，删除了" (itoa i) "个重复圆或圆弧.\n"))
(princ)
)
(defun arc_data      (ent / BJ DATA EANGL PC SANGL)
(setq data (entget ent))
(setq bj (cdr (assoc 40 data)))
(setq pc (cdr (assoc 10 data)))
(setq sangl (cdr (assoc 50 data)))
(setq eangl (cdr (assoc 51 data)))
(if (not sangl)
    (setq sangl      0.0
          eangl      (+ pi pi)
    )
)
(if (< eangl sangl)
    (setq eangl (+ eangl (+ pi pi)))
)
(list bj (car pc) (cadr pc) sangl eangl ent)
)
(defun line_data (ent / b k p1 p2)
(setq   obj (vlax-ename->vla-object ent)
   p1 (vlax-curve-getstartpoint obj)
      p2 (vlax-curve-getendpoint obj)
)
(if (equal (car p1) (car p2) jd)
    (setq k nil
          b (car p1)
    )
    (setq k (/ (- (cadr p2) (cadr p1))
               (- (car p2) (car p1))
            )
          b (- (cadr p1) (* (car p1) k))
    )
)
(setq      p2 (vl-sort (list p1 p2)
                  '(lambda (e1 e2)
                     (if (equal (car e1) (car e2) jd)
                         (< (cadr e1) (cadr e2))
                         (< (car e1) (car e2))
                     )
                     )
         )
      p1 (car p2)
      p2 (cadr p2)
)
(list      k
      b
      (list (car p1) (cadr p1))
      (list (car p2) (cadr p2))
      ent
)
)
;;; *****消除重线 程序结束*****

雨夜屠夫 发表于 2017-11-17 11:39:33

这个有个问题，能否先把短线直接删除，而不是用点坐标判断后再附值到一根线中？

78946299 发表于 2022-4-17 12:09:11

挺好用得，大佬能帮忙改下下吗？不管是不是同一个图层都能除去重复的。谢谢您

阿秀 发表于 2024-3-30 08:41:35

您好，我想付费做一个删除重复线的功能，看到信息加我微信18520932885

zhangrunze 发表于 2024-3-26 09:20:40

学习了~
感谢分享代码~

mmlzyz15 发表于 2022-9-15 20:36:08

这种给代码的咋用啊:Q

JUN1 发表于 2022-7-26 10:15:18

高级顶顶高级顶顶

tomonkey239 发表于 2022-4-18 15:48:05

感谢，，，学习学习了

xzd716 发表于 2021-11-19 21:23:52

谢谢楼主分享

lcyjl 发表于 2020-9-20 08:57:14

我也编了一个这样的程序，只是只限于直线，这个程序更牛

juliana207 发表于 2020-9-19 23:05:13

学习一下 111

查看完整版本: 消除重复的直线、圆弧