消除重复的直线、圆弧

荒野孤行

对直线的消除重线算法，会将直线转换为了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)
)
(defun hbzhx (ss /)
  (grtext -2 "正在整理数据")
  (initget 4)
  (if (not (setq jd (getreal "\n输入精度要求：<0.0001>\n")))
    (setq jd 1e-4)
  )
  (setq        i 0
        line_list '()
        arc_list '()
  )
  (repeat (sslength ss)
    (setq ent (ssname ss i)
          i   (1+ i)
    )
    (setq obj (vlax-ename->vla-object ent))
    (if        (> (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))
           jd
        )
      (if (= "LINE" (cdr (assoc 0 (entget ent))))
        (setq line_list (cons (line_data ent) line_list))
        (setq arc_list (cons (arc_data ent) arc_list))
      )
    )
  )
  (setq        line_list
         (vl-sort
           line_list
           '(lambda (e1 e2)
              (if (equal (car e1) (car e2) jd)
                (if (equal (cadr e1) (cadr e2) jd)
                  (if (equal (car (caddr e1)) (car (caddr e2)) jd)
                    (< (cadr (caddr e1)) (cadr (caddr e2)))
                    (< (car (caddr e1)) (car (caddr e2)))
                  )
                  (< (cadr e1) (cadr e2))
                )
                (< (car e1) (car e2))
              )
            )
         )
  )
  (setq        arc_list (vl-sort arc_list
                          '(lambda (e1 e2)
                             (if (equal (car e1) (car e2) jd)
                               (if (equal (cadr e1) (cadr e2) jd)
                                 (if (equal (caddr e1) (caddr e2) jd)
                                   (< (cadddr e1) (cadddr e2))
                                   (< (caddr e1) (caddr e2))
                                 )
                                 (< (cadr e1) (cadr e2))
                               )
                               (< (car e1) (car e2))
                             )
                           )
                 )
  )
  (if line_list
    (hb_line line_list jd)
  )
  (if arc_list
    (hb_arc arc_list jd)
  )
  (grtext)
  (princ)
)
(defun hb_line (line_list jd /)
  (setq        zongshu        (length line_list)
        i        0
        xuhao        0
  )
  (princ (strcat "\n共处理" (itoa zongshu) "个直线实体"))
  (grtext -1 "合并直线")
  (while (> (length line_list) 0)
    (setq xuhao (1+ xuhao))
    (cs_pross zongshu xuhao)
    (setq line_a    (car line_list)
          line_list (cdr line_list)
          biaoji    t
          k            (car line_a)
          b            (cadr line_a)
          p1            (caddr line_a)
          p2            (cadddr line_a)
          ent            (last line_a)
          lay            (cdr (assoc 8 (entget ent)))
    )
    (while (and        biaoji
                (> (length line_list) 0)
           )
      (setq line_b (car line_list))
      (cond
        ((and (equal k (car line_b) jd)
              (equal b (cadr line_b) jd)
              (= lay (cdr (assoc 8 (entget (last line_b)))))
         )
         (setq p3 (caddr line_b)
               p4 (cadddr line_b)
               p5 (vl-sort (list p1 p2 p3 p4)
                           '(lambda (e1 e2)
                              (if (equal (car e1) (car e2) jd)
                                (< (cadr e1) (cadr e2))
                                (< (car e1) (car e2))
                              )
                            )
                  )
               p4 (cadr p5)
         )
         (if (or (equal p1 p4 jd)
                 (equal p3 p4 jd)
             )
           (progn
             (setq p1             (car p5)
                   p2             (last p5)
                   line_list (cdr line_list)
             )
             (entdel (last line_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 10 p1) (assoc 10 data) data)
          data (subst (cons 11 p2) (assoc 11 data) data)
    )
    (entmod data)
  )
  (princ (strcat "，删除了" (itoa i) "条重复直线.\n"))
  (princ)
)
(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
  )
)
;;; *****消除重线 程序结束*****

雨夜屠夫

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

78946299

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

阿秀

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

zhangrunze

学习了~
感谢分享代码~

mmlzyz15

这种给代码的咋用啊:Q

JUN1

高级顶顶高级顶顶

tomonkey239

感谢，，，学习学习了

xzd716

谢谢楼主分享

lcyjl

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

juliana207

学习一下 111