消除重复的直线、圆弧

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

对直线的消除重线算法，会将直线转换为了f(x)=kx+b的形式；对于由多个圆心及半径相同的圆弧而组成的圆形，消除重线时会出现错误的效果（正确的应该是组成一个完整的圆），Express中的Overkill命令也有这个问题，这里给出的不是完善的源码，已完善的程序已集成在中。
;;; *****消除重线程序开始*****
(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输入精度要求：\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)
                  ( (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)
                              ( (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)
                              (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)
                     (演示

nz5ybjyxy5w.gif