（完成）[编程申请]：求改进“消除重线”

秋枫

现在的消除重线只能对图层或全图消。

希望改成可以对手动选择的选择集消。而且，选择集中再针对图层分别消重。这样，对于80M以上的大dwg图，可操作性强一点。

XDSoft

2. 
   
3. [FONT=courier new]
   
4. ;|
   
5.    命令：curve_rdup1
   
6.    
   
7.    功能：速度极快的，交互选取LINE,ARC,CIRCLE，然后分层消除重线
   
8. |;
   
9. (defun c:curve_rdup1 (/ ss el e lyr old new el ss1 short_l n sl num len
   
10.                         rline sline rarc sarc rcir
    
11.                      )
    
12.   (prompt "\n请选取要消除重线的(Line、Arc、Circle)实体[分层消重]<退出>:")
    
13.   (if (setq ss (ssget '((0 . "line,arc,circle"))))
    
14.     (progn
    
15.       (xdrx_setsstodb ss 0)
    
16.       (setq el nil)
    
17.       (while (setq e (xdrx_getentdata 0))
    
18.         (setq lyr (xdrx_getentdxf 8))
    
19.         (if (setq old (assoc lyr el))
    
20.           (progn
    
21.             (setq new (cons lyr (cons e (cdr old))))
    
22.             (setq el (subst
    
23.                        new
    
24.                        old
    
25.                        el
    
26.                      )
    
27.             )
    
28.           )
    
29.           (progn
    
30.             (setq el (cons (list lyr e) el))
    
31.           )
    
32.         )
    
33.       )
    
34.       (setq ss1 (mapcar
    
35.                   '(lambda (x)
    
36.                      (setq sl (cdr x)
    
37.                            ss (ssadd)
    
38.                      )
    
39.                      (foreach n sl
    
40.                        (ssadd n ss)
    
41.                      )
    
42.                      (cons (car x) ss)
    
43.                    )
    
44.                   el
    
45.                 )
    
46.       )
    
47.       (setq short_l 100)               ; 超短线长度，可以修改该值
    
48.       (foreach n ss1
    
49.         (prompt (strcat "\n处理" (car n) "层中，稍后..."))
    
50.         (setq num (xdrx_curve_remove_dup (cdr n) short_l 10 100))
    
51.         (setq len (sslength ss)
    
52.               sline (cadar num)
    
53.               rline (caar num)
    
54.               rarc (caadr num)
    
55.               sarc (cadadr num)
    
56.               rcir (car (last num))
    
57.         )
    
58.         (prompt (strcat "\n 搜索到 Line,Arc,Circle 共:" (itoa len)
    
59.                         "\n 删除超短线: " (itoa sline) " 删除重线: "
    
60.                         (itoa rline) "\n 删除超短弧: " (itoa sarc)
    
61.                         " 删除重弧: " (itoa rarc) "\n 删除重圆: "
    
62.                         (itoa rcir) "\n 还剩: " (itoa (- len sline rline
    
63.                                                          sarc rarc rcir
    
64.                                                       )
    
65.                                                 )
    
66. 
    
67.                 )
    
68.         )
    
69.         (princ "\n")
    
70.       )
    
71.     )
    
72.   )
    
73.   (princ)
    
74. )
    
75. [/FONT]

<br /> [FONT=courier new]<br /> ;|<br />    命令：curve_rdup1<br />    <br />    功能：速度极快的，交互选取LINE,ARC,CIRCLE，然后分层消除重线<br /> |;<br /> (defun c:curve_rdup1 (/ ss el e lyr old new el ss1 short_l n sl num len<br />                         rline sline rarc sarc rcir<br />                      )<br />   (prompt "\n请选取要消除重线的(Line、Arc、Circle)实体[分层消重]<退出>:")<br />   (if (setq ss (ssget '((0 . "line,arc,circle"))))<br />     (progn<br />       (xdrx_setsstodb ss 0)<br />       (setq el nil)<br />       (while (setq e (xdrx_getentdata 0))<br />         (setq lyr (xdrx_getentdxf 8))<br />         (if (setq old (assoc lyr el))<br />           (progn<br />             (setq new (cons lyr (cons e (cdr old))))<br />             (setq el (subst<br />                        new<br />                        old<br />                        el<br />                      )<br />             )<br />           )<br />           (progn<br />             (setq el (cons (list lyr e) el))<br />           )<br />         )<br />       )<br />       (setq ss1 (mapcar<br />                   '(lambda (x)<br />                      (setq sl (cdr x)<br />                            ss (ssadd)<br />                      )<br />                      (foreach n sl<br />                        (ssadd n ss)<br />                      )<br />                      (cons (car x) ss)<br />                    )<br />                   el<br />                 )<br />       )<br />       (setq short_l 100)               ; 超短线长度，可以修改该值<br />       (foreach n ss1<br />         (prompt (strcat "\n处理" (car n) "层中，稍后..."))<br />         (setq num (xdrx_curve_remove_dup (cdr n) short_l 10 100))<br />         (setq len (sslength ss)<br />               sline (cadar num)<br />               rline (caar num)<br />               rarc (caadr num)<br />               sarc (cadadr num)<br />               rcir (car (last num))<br />         )<br />         (prompt (strcat "\n 搜索到 Line,Arc,Circle 共:" (itoa len)<br />                         "\n 删除超短线: " (itoa sline) " 删除重线: "<br />                         (itoa rline) "\n 删除超短弧: " (itoa sarc)<br />                         " 删除重弧: " (itoa rarc) "\n 删除重圆: "<br />                         (itoa rcir) "\n 还剩: " (itoa (- len sline rline<br />                                                          sarc rarc rcir<br />                                                       )<br />                                                 )<br /> <br />                 )<br />         )<br />         (princ "\n")<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> [/FONT]

请下载下面附件拷贝到“晓东工具箱”LISP目录覆盖原来文件...

carming

不完全重合搞不了...

vivianzz

下不来啊

kwok

重叠的线,有的点错位也消不了,应该是不管是什么线,只要重叠就消除.就算两线重叠一半也消除.
可以做到这样就好了.....!!当然也要想消那里就选那里.这样才不会用太多时间.

peiczg

怎么使用阿 最好象5楼说的那样

月影水飘飘

稍有偏差的怎么处理?

就是宽线PLINE 炸开后的 近似重线

caocao413a

学习了，这东西太实用了啊！！！！！