明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 14024|回复: 34

申請刪重複線程序.

  [复制链接]
发表于 2003-8-3 14:49 | 显示全部楼层 |阅读模式
申請刪重複線程序.謝謝!!!
发表于 2003-8-4 08:57 | 显示全部楼层
这个帖子你应该看过的,里面有链接
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=8043
 楼主| 发表于 2003-8-4 10:04 | 显示全部楼层
這個刪重複線程序,有時候根本就刪除不了.
发表于 2003-8-4 17:20 | 显示全部楼层
再說明白點and提供圖面供測試!
 楼主| 发表于 2003-8-4 18:52 | 显示全部楼层

奇怪dwg怎麼上傳不了,只能壓縮後再上傳.
我用duprem命令刪除不了

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2003-8-5 12:52 | 显示全部楼层
那是重疊,不是重復!!
 楼主| 发表于 2003-8-8 18:08 | 显示全部楼层
那能不能再改一下程序也可以刪重疊線呢???
发表于 2003-8-8 22:26 | 显示全部楼层
是啊,谁能提供一个?
发表于 2003-8-13 16:19 | 显示全部楼层
试试这个,不过只是对付Line线的
;;;标题: 【解决方案】消除重线的LISP程序,使用纯LISP函,
;;;适用于任何AUTOCAD平台。不考虑图层,只要是重线就处理。

;;;________________________________________________________
(defun ww ()
  (setq ls (Entsel "\n 请选取一条直线:..."))
  (setq ls (car ls))
  (setq        p1 (trans (cdr (Assoc 10 (entget ls))) 0 1)
        p2 (trans (cdr (Assoc 11 (entget ls))) 0 1)
  )
  (setq        ls  (angle p1 p2)
        ls1 (+ ls (* pi 1.5))
  )
  (setq p0 (getpoint "\n 请输入一个点!.."))
;;;  (setq p0 (trans p0 1 0))
  (setq pe (polar p0 ls1 1))
  (setq pp (inters p1 p2 p0 pe nil))
  (setq #l (distance pp p0))
  (princ "\n 距离为:")
  (princ #l)
)
;;;________________________________________________________

;;;内容:
;;;清重 LINE
;;;消除重线,不生成任何新的LINE
;;;程序没考虑图层,只要是重线,就处理
;;;内有详细的注释,帮助朋友理解开发思路。
;;;这个程序很复杂,用了很多技巧。希望能对朋友有帮助
;;;命令:c:rdup

(setvar "cmdecho" 0)
;;;子程序 (ran), 将LISP表按关键字排序。参数 'a' 为要排序的LISP表。
;;;例如执行程序:   (ran '((3 3.2) (5.4 4.8) (3 3) (-0.4 5.5) (3 3)))
;;;该程序将返回:   ((-0.4 5.5) (3 3) (3 3.2) (5.4 4.8))
(defun ran (a / b c d mn mx)
  (setq        c  (mapcar 'car a)
        mn (apply 'min c)
        mn (1- mn)
  )
  (while (< mn (setq mx (apply 'max c)))
    (setq c (subst mn mx c))
    (while (setq d (assoc mx a))
      (setq a (subst '(nil) d a)
            b (cons d b)
      )
    )
  )
  b
)

;;;子程序 (rz), 消去点 'p' 的 Z-坐标。
(defun rz (p) (list (car p) (cadr p)))

;;;子程序 (p-l1), 求点到直线距离程序的前半部分 (求常数'c1','c2'和'c3')。
;;;参数 'p1' 和 'p2' 为直线的两个端点。
(defun p-l1 (p1 p2 / x1 y1 x2 y2)
  (setq        x1 (car p1)
        y1 (cadr p1)
        x2 (car p2)
        y2 (cadr p2)
        c1 (- y2 y1)
        c2 (- x1 x2)
        c3 (sqrt (+ (* c1 c1) (* c2 c2)))
        c1 (/ c1 c3)
        c2 (/ c2 c3)
        c3 (/ (- (* x2 y1) (* x1 y2)) c3)
  )
)

;;;子程序 (p-l2), 求点到直线距离程序的后半部分 (返回距离值)。
;;;参数 'p0' 为点坐标。
(defun p-l2 (p0) (+ (* c1 (car p0)) (* c2 (cadr p0)) c3))

;;;子程序 (rddo1), 合并一条直线上的各线段。
(defun rddo1 (l2 / e el c1 c2 c3 ln1 ll1 ll2 ll3 ll4 lle len len1 p z)
  (setq        ll (car l2)
        p1 (car ll)
        p2 (cadr ll)
        a1 (angle p1 p2)
        p3 (polar p1 (+ pi2 a1) mx)
        n  (+ n (length l2))
  )
;;;分别求出直线上某点到各线段上两个端点的距离, 并与实体名一同存入表 'll1'。
;;;表 'll1' 的格式为   ((距离1 实体名1) (距离2 实体名2) . . .)。
;;;'lle' 为各线段的实体名表, 格式为   (实体名1  实体名2 . . .)
  (p-l1 p1 p3)
  (foreach ll l2
    (setq e   (last ll)
          ll1 (cons (list (p-l2 (car ll)) e) ll1)
          ll1 (cons (list (p-l2 (cadr ll)) e) ll1)
          lle (cons e lle)
    )
  )
;;;'ll2' 为临时实体名表, 格式为 (实体名1 实体名2 . . .)。
;;;'ll4' 为合并完成后的线段表, 格式为 ((首端1 . 末端1) (首端2 . 末端2) . . .)。
  (setq        ll1 (ran ll1)
        ln1 (+ mx (caar ll1))
        ll4 nil
  )
  (foreach ll ll1
    (setq ln (car ll)
          e  (cadr ll)
    )
    (if        ll2
      (progn
;;;此时有重叠的线段。
        (setq ll3 (member e ll2)
              ll2 (if ll3
                    (append (cdr ll3) (cdr (member e (reverse ll2))))
;;;结束一条重线。
                    (cons e ll2)        ;将新重线的实体名加入 'll2'。
                  )
        )
        (if (not ll2)
;;;结束一条线的合并, 将其存入 'll4'。
          (setq        ll4 (cons (cons (polar p1 a1 ln) p2) ll4)
                ln1 ln
          )
        )
      )
      (progn
;;;此时没有重叠的线段。
        (if (equal ln1 ln mm)
          (setq ll4 (cdr ll4))                ;消去前一条线, 使首尾相接的两条线连续。
          (setq p2 (polar p1 a1 ln))        ;求出一条新线的起始点。
        )
        (setq ll2 (cdr ll))                ;将起点实体名加入 'll2'。
      )
    )
  )
  (if (> (setq len  (length ll4)
               len1 (length lle)
         )
         len
      )
    (progn
      (repeat (- len1 len)
        (setq e          (car lle)
              lle (cdr lle)
        )
        (entdel e)
      )
;;;用表 'll4' 中的线段更新表 'lle' 中的线段。
      (foreach ll ll4
        (setq e          (car lle)
              lle (cdr lle)
              el  (entget e)
              p          (assoc 10 el)
              z          (cdddr p)
              el  (subst (cons 10 (append (car ll) z)) p el)
              el  (subst (cons 11 (append (cdr ll) z)) (assoc 11 el) el)
        )
        (entmod el)
      )
    )
  )
  (setq n (- n len))
;;;每画 40 根线, 在提示行更新一次报数。
  (if (> (- n n2) 40)
    (progn
      (setq n2 n)
      (princ (strcat st2 (itoa n)))
    )
  )
)

;;;子程序 (rddo), 对一组同角度的线段进行重线合并。
;;;参数 'l0' 为线段表, 其格式为
;;;    ((首端1 末端1 实体名1) (首端2 末端2 实体名2) . . .)。
(defun rddo (l0 / e1 a1 p1 p2 p3 c1 c2 c3 ln l1 l2 ll ll1)
  (setq        ll (car l0)
        p1 (car ll)
        p2 (cadr ll)
        l1 (list (list 0. ll))
  )
;;;将 'l0' 中各项, 按距离进行分类存入表 'l1'
;;;'l1' 的格式为 ((距离1 (首端1 末端1 实体名1)
;;;                      (首端2 末端2 实体名2) . . .) . . .)
  (p-l1 p1 p2)
  (foreach ll (cdr l0)
;;;变量 'ln' 为该线段与首根直线的距离。
    (setq ln (p-l2 (car ll))
          l2 l1
    )
    (while (and (setq ll1 (car l2)) (not (equal ln (car ll1) mm)))
      (setq l2 (cdr l2))
    )
;;;将距离值近似的线段归入同一个子表内, 否则另开一个新的子表。
    (setq l1 (if ll1
               (subst (append ll1 (list ll)) ll1 l1)
               (cons (list ln ll) l1)
             )
    )
  )
;;;对表 'l1' 中各组同距离 (即在一条直线上) 的线段进行重线合并。
  (foreach l2 l1
    (setq l2 (cdr l2))
    (if        (cdr l2)
      (rddo1 l2)
    )                                        ;一组线多于一根才进行处理。
  )
)

;;;主程序 (c:rdup), 合并或去除重线 (处理图内全部 LINE 实体)。
(defun c:rdup (/ osm mm        mx pi2 st1 st2 ss1 e1 el1 n n1 n2 a1 p1        p2 l1 ll
               ll1)
  (gc)
  (prompt "\n选取要处理的LINE<全选>:")
  (if (not (setq ss1 (ssget '((0 . "LINE")))))
    (setq ss1 (ssget "x" '((0 . "LINE"))))
  )
;;;变量 'mm' 为距离微量 (在该距离内的线段均视为重合)。
  (command "undo" "be")
  (setq        osm (getvar "osmode")
        mx  (getvar "viewsize")
        mm  (* 3e-4 mx)
        pi2 (/ pi 2)
        st1 "\r搜索到直线数: "
        st2 "\r已经去除重线数: "
        n   0
        n1  0
        n2  0
  )
  (setvar "osmode" 0)
  (setvar "highlight" 0)
  (princ "\n")
;;;对全体 LINE 实体, 按角度进行分类存入表 'l1'。
;;;'l1' 的格式为 ((角度1 (首端1 末端1 实体名1)
;;;                      (首端2 末端2 实体名2) . . .) . . .)。
  (while (setq e1 (ssname ss1 n))
    (setq n   (1+ n)
          el1 (entget e1)
          p1  (rz (cdr (assoc 10 el1)))
          p2  (rz (cdr (assoc 11 el1)))
    )
    (if        (equal p1 p2 mm)
      (progn;;;线段长度小于 'mm', 认为是超短线, 做擦除处理。
        (entdel e1)
        (setq n1 (1+ n1))
      );;;将角度值近似的线段归入同一个子表内, 否则另开一个新的子表。
      (setq ll1        (list (list p1 p2 e1))
            a1        (angle p1 p2)
            a1        (rtos (if (< a1 pi)
                        a1
                        (- a1 pi)
                      )
                      2
                      3
                )
            ll        (assoc a1 l1)
            l1        (if ll
                  (subst (append ll ll1) ll l1)
                  (cons (cons a1 ll1) l1)
                )
      )
    )

;;;每处理 128 根线, 在提示行更新一次报数。
    (if        (= 127 (logand 127 n))
      (princ (strcat st1 (itoa n)))
    )
  )
  (princ (strcat st1
                 (itoa n)
                 (if (zerop n1)
                   ""
                   (strcat ".  删除超短线 " (itoa n1))
                 )
                 ".\n"
         )
  )
  (setq        n1 (- n n1)
        n  0
  );;;对表 'l1' 中各组同角度的线段进行重线合并。
  (foreach ll l1
    (setq ll (cdr ll))
    (if        (cdr ll)
      (rddo ll)
    );;;一组线多于一根才进行处理。
  )
  (princ (strcat st2
                 (itoa n)
                 ".  还剩 "
                 (itoa (- n1 n))
                 " 条线."
         )
  )
  (redraw)
  (command "undo" "e")
  (setvar "osmode" osm)
  (setvar "highlight" 1)
  (princ)
)
 楼主| 发表于 2003-8-15 12:28 | 显示全部楼层
謝謝,挺好用.
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-28 23:34 , Processed in 0.239204 second(s), 25 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表