求帮忙改代码，清除重线。

wgij007

求帮忙改代码，出处明经，忘了那个贴了，如有侵犯请提出，必改.
取消精度确认这个，直接在程序里设好就可以了。清除后移到指定的层，可在程序里设置。现要选运行命令再选,改为可先选再运行命令.CAD2006.谢谢。

(defun C:lr ()
  (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
  )
)
;;; *****消除重线 程序结束*****

845245015

wgij007 发表于 2021-3-5 16:38
能不能不要输入，直接转，如dim层

(defun C:lr ()
  (princ "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！")
  (setvar "cmdecho" 0)
  (setvar "plinewid" 0)
  (command "undo" "be")
  (vl-load-com)
  (if (not (setq ss (ssget "p" '((0 . "ARC,LINE")))))
    (setq ss (ssget '((0 . "ARC,LINE"))))
    )
  ;(setq Nme (getstring "\n请输入图层名称<默认图层名称：!!!!!!XREF>"))
  ;(if (or (= 33 (ascii Nme))(= 0 (ascii Nme)))
    (setq Nme "dim")
    ;)
  (if (= (tblsearch "layer" Nme) nil)
    (entmake (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
               '(290 . 0)
               (cons 2 Nme)
               (cons 62 1)
               )
             )
    )
  
  (if ss
    (progn
      (setq lz_i -1)
      (while (setq pl (ssname ss (setq lz_i (1+ lz_i))))
        (setq #g (entget pl))
        (setq #g (subst (cons 8 Nme) (assoc 8 #g) #g))
        (entmod #g)
        )
      )
    )
  (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
  )
)
;;; *****消除重线 程序结束*****

845245015

(defun C:lr ()
  (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
  )
)
;;; *****消除重线 程序结束*****

wgij007

845245015 发表于 2021-3-5 11:43
(defun C:lr ()
  (princ
    "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！"

运行错误，错误: quit / exit abort
你好，能改成可以先选再运行命令吗，谢谢了.

yoyoho

845245015 发表于 2021-3-5 11:43
(defun C:lr ()
  (princ
    "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！"

AUTOCAD 2012 测试 O.K.

845245015

wgij007 发表于 2021-3-5 12:16
运行错误，错误: quit / exit abort
你好，能改成可以先选再运行命令吗，谢谢了.

(defun C:lr ()
  (princ
    "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！"
  )
  (setvar "cmdecho" 0)
  (setvar "plinewid" 0)
  (command "undo" "be")
  (vl-load-com)
  (if (not (setq ss (ssget "p" '((0 . "ARC,LINE")))))
    (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
  )
)
;;; *****消除重线 程序结束*****

wgij007

845245015 发表于 2021-3-5 12:50
(defun C:lr ()
  (princ
    "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！"
...

转移到指定图层没有呀

845245015

wgij007 发表于 2021-3-5 13:52
转移到指定图层没有呀

(defun C:lr ()
  (princ "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！")
  (setvar "cmdecho" 0)
  (setvar "plinewid" 0)
  (command "undo" "be")
  (vl-load-com)
  (if (not (setq ss (ssget "p" '((0 . "ARC,LINE")))))
    (setq ss (ssget '((0 . "ARC,LINE"))))
    )
  (setq Nme (getstring "\n请输入图层名称<默认图层名称：!!!!!!XREF>"))
  (if (or (= 33 (ascii Nme))(= 0 (ascii Nme)))
    (setq Nme "!!!!!!XREF")
    )
  (if (= (tblsearch "layer" Nme) nil)
    (entmake (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
               '(290 . 0)
               (cons 2 Nme)
               (cons 62 1)
               )
             )
    )
  
  (if ss
    (progn
      (setq lz_i -1)
      (while (setq pl (ssname ss (setq lz_i (1+ lz_i))))
        (setq #g (entget pl))
        (setq #g (subst (cons 8 Nme) (assoc 8 #g) #g))
        (entmod #g)
        )
      )
    )
  (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
  )
)
;;; *****消除重线 程序结束*****

wgij007

845245015 发表于 2021-3-5 15:44
(defun C:lr ()
  (princ "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！")
  ( ...

能不能不要输入，直接转，如dim层

wgij007

845245015 发表于 2021-3-5 15:44
(defun C:lr ()
  (princ "\n★功能：删除重复的直线、圆弧.\n提示：只可删除在相同图层的重线！")
  ( ...

差不多了，感谢。