[原创]：高效的合并直线程序，敬请使用。

lijiao

我在http://www.xdcad.net/forum/showthread.php?s=&postid=434934贴了一个关于合并直线的程序，它的功能是合并相互重叠或首尾相接的直线，后来在实际使用过程中发现，如果选中的实体过多时（500个以上），处理速度会很慢。近几天，我修改了处理方式，速度大幅度提升，一次50000个以上的实体，速度仍然能够接受。
另外还增加了两个功能，一是只能将相同图层的直线合并，二是增加了进度的显示。
欢迎各位使用，并提出宝贵意见，不收钱了。

lzy9788

这个函数ACET-UI-PROGRESS没有定义

lijiao

需要安装ET工具

yangjr

请问加载后如何调用。

lijiao

加载后有提示啊，用HBZHX调用

harrywang77

能否提供源碼交流，願交換自己開發的LISP

lijiao

最初由 harrywang77 发布
[B]能否提供源碼交流，願交換自己開發的LISP [/B]

2. 
   
3.   [FONT=courier new]
   
4. (defun c:hbzhx (/ ss ss1 ss2 ss3 ss4 sslay item        p1 p2 xuhao zongshu
   
5.                 ssbak step)
   
6.   (cond
   
7.     ((and
   
8.        (setq ss (ssget (list (cons 0 "LINE"))))
   
9.        (> (sslength ss) 1)
   
10.      )
    
11.      (setq ss (ss->list ss))
    
12.      (setq zongshu (/ 100.0 (length ss)))
    
13.      (setq xuhao 0
    
14.            step        1
    
15.      )
    
16.      (acet-ui-progress "已经完成" 100)
    
17.      (setq ssbak ss)
    
18.      (while (> (length ss) 0)
    
19.        (setq ss1 (car ss)
    
20.              ss         (vl-remove ss1 ss)
    
21.        )
    
22.        (setq xuhao (+ xuhao zongshu))
    
23.        (if (= (fix xuhao) step)
    
24.          (progn
    
25.            (acet-ui-progress -1)
    
26.            (setq step (1+ step))
    
27.          )
    
28.        )
    
29.        (vla-GetBoundingBox (vlax-ename->vla-object ss1) 'p1 'p2)
    
30.        (setq p1        (vlax-safearray->list p1)
    
31.              p2        (vlax-safearray->list p2)
    
32.        )
    
33.        (setq sslay (vla-get-layer (vlax-ename->vla-object ss1)))
    
34.        (setq
    
35.          ss3 (ssget "c" p1 p1 (list (cons 0 "LINE") (cons 8 sslay)))
    
36.        )
    
37.        (setq
    
38.          ss4 (ssget "c" p2 p2 (list (cons 0 "LINE") (cons 8 sslay)))
    
39.        )
    
40.        (setq ss3 (ss->list ss3))
    
41.        (setq ss3 (vl-remove ss1 ss3))
    
42.        (setq ss4 (ss->list ss4))
    
43.        (setq ss4 (vl-remove ss1 ss4))
    
44.        (foreach        item ss4
    
45.          (setq ss3 (cons item ss3))
    
46.        )
    
47.        (while (> (length ss3) 0)
    
48.          (setq ss2 (car ss3)
    
49.                ss3 (vl-remove ss2 ss3)
    
50.          )
    
51.          (if (and
    
52.                (member ss2 ssBAK)
    
53.                (hbline ss1 ss2)
    
54.              )
    
55.            (progn
    
56.              (setq ss (vl-remove ss2 ss))
    
57.              (setq xuhao (+ xuhao zongshu))
    
58.              (if (= (fix xuhao) step)
    
59.                (progn
    
60.                  (acet-ui-progress -1)
    
61.                  (setq step (1+ step))
    
62.                )
    
63.              )
    
64.              (entdel ss2)
    
65.            )
    
66.          )
    
67.        )
    
68.      )
    
69.      (acet-ui-progress)
    
70.     )
    
71.     (t nil)
    
72.   )
    
73.   (princ)
    
74. )
    
75. (defun ss->list        (ss / cs_i out)
    
76.   (if (= (type ss) 'PICKSET)
    
77.     (progn
    
78.       (setq cs_i 0.0
    
79.             out         '()
    
80.       )
    
81.       (repeat (sslength ss)
    
82.         (setq out (cons (ssname ss cs_i) out))
    
83.         (setq cs_i (1+ cs_i))
    
84.       )
    
85.       (setq out (reverse out))
    
86.     )
    
87.   )
    
88. )
    
89. (defun hbline (ent_line1         ent_line2           /            ent_data1
    
90.                ent_data2         pt          p1           p2            p3
    
91.                p4        dis1         dis2          dis3           dis4            dis
    
92.               )
    
93.   (setq        ent_data1 (entget ent_line1)
    
94.         ent_data2 (entget ent_line2)
    
95.         p1          (cdr (assoc 10 ent_data1))
    
96.         p2          (cdr (assoc 11 ent_data1))
    
97.         p3          (cdr (assoc 10 ent_data2))
    
98.         p4          (cdr (assoc 11 ent_data2))
    
99.         dis          (distance p1 p2)
    
100.         dis1          (distance p1 p3)
     
101.         dis2          (distance p2 p3)
     
102.         dis3          (distance p1 p4)
     
103.         dis4          (distance p2 p4)
     
104.   )
     
105.   (if (and
     
106.         (equal (+ dis dis1 dis2)
     
107.                (* 2.0 (max dis dis1 dis2))
     
108.                0.000001
     
109.         )
     
110.         (equal (+ dis dis3 dis4)
     
111.                (* 2.0 (max dis dis3 dis4))
     
112.                0.000001
     
113.         )
     
114.       )
     
115.     (progn
     
116.       (if (or (equal 90.0 (rtod (angle p1 p2)) 20)
     
117.               (equal 270 (rtod (angle p1 p2)) 20)
     
118.           )
     
119.         (setq pt
     
120.                (vl-sort        (list p1 p2 p3 p4)
     
121.                         (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))
     
122.                )
     
123.         )
     
124.         (setq pt
     
125.                (vl-sort        (list p1 p2 p3 p4)
     
126.                         (function (lambda (e1 e2) (< (car e1) (car e2))))
     
127.                )
     
128.         )
     
129.       )
     
130.       (setq p1              (cons 10 (car pt))
     
131.             p2              (cons 11 (nth 3 pt))
     
132.             ent_data1 (subst p1 (assoc 10 ent_data1) ent_data1)
     
133.             ent_data1 (subst p2 (assoc 11 ent_data1) ent_data1)
     
134.       )
     
135.       (entmod ent_data1)
     
136.     )
     
137.   )
     
138. )
     
139. (defun rtod (dat /)
     
140.   (* 180.0 (/ dat pi))
     
141. )
     
142. (princ "\n本程序由李蛟编写,功能是合并相同图层里的首尾相接或重叠的直线，用HBZHX调用。")
     
143. (princ)
     
144.   [/FONT]
     

<br />   [FONT=courier new]<br /> (defun c:hbzhx (/ ss ss1 ss2 ss3 ss4 sslay item        p1 p2 xuhao zongshu<br />                 ssbak step)<br />   (cond<br />     ((and<br />        (setq ss (ssget (list (cons 0 "LINE"))))<br />        (> (sslength ss) 1)<br />      )<br />      (setq ss (ss->list ss))<br />      (setq zongshu (/ 100.0 (length ss)))<br />      (setq xuhao 0<br />            step        1<br />      )<br />      (acet-ui-progress "已经完成" 100)<br />      (setq ssbak ss)<br />      (while (> (length ss) 0)<br />        (setq ss1 (car ss)<br />              ss         (vl-remove ss1 ss)<br />        )<br />        (setq xuhao (+ xuhao zongshu))<br />        (if (= (fix xuhao) step)<br />          (progn<br />            (acet-ui-progress -1)<br />            (setq step (1+ step))<br />          )<br />        )<br />        (vla-GetBoundingBox (vlax-ename->vla-object ss1) 'p1 'p2)<br />        (setq p1        (vlax-safearray->list p1)<br />              p2        (vlax-safearray->list p2)<br />        )<br />        (setq sslay (vla-get-layer (vlax-ename->vla-object ss1)))<br />        (setq<br />          ss3 (ssget "c" p1 p1 (list (cons 0 "LINE") (cons 8 sslay)))<br />        )<br />        (setq<br />          ss4 (ssget "c" p2 p2 (list (cons 0 "LINE") (cons 8 sslay)))<br />        )<br />        (setq ss3 (ss->list ss3))<br />        (setq ss3 (vl-remove ss1 ss3))<br />        (setq ss4 (ss->list ss4))<br />        (setq ss4 (vl-remove ss1 ss4))<br />        (foreach        item ss4<br />          (setq ss3 (cons item ss3))<br />        )<br />        (while (> (length ss3) 0)<br />          (setq ss2 (car ss3)<br />                ss3 (vl-remove ss2 ss3)<br />          )<br />          (if (and<br />                (member ss2 ssBAK)<br />                (hbline ss1 ss2)<br />              )<br />            (progn<br />              (setq ss (vl-remove ss2 ss))<br />              (setq xuhao (+ xuhao zongshu))<br />              (if (= (fix xuhao) step)<br />                (progn<br />                  (acet-ui-progress -1)<br />                  (setq step (1+ step))<br />                )<br />              )<br />              (entdel ss2)<br />            )<br />          )<br />        )<br />      )<br />      (acet-ui-progress)<br />     )<br />     (t nil)<br />   )<br />   (princ)<br /> )<br /> (defun ss->list        (ss / cs_i out)<br />   (if (= (type ss) 'PICKSET)<br />     (progn<br />       (setq cs_i 0.0<br />             out         '()<br />       )<br />       (repeat (sslength ss)<br />         (setq out (cons (ssname ss cs_i) out))<br />         (setq cs_i (1+ cs_i))<br />       )<br />       (setq out (reverse out))<br />     )<br />   )<br /> )<br /> (defun hbline (ent_line1         ent_line2           /            ent_data1<br />                ent_data2         pt          p1           p2            p3<br />                p4        dis1         dis2          dis3           dis4            dis<br />               )<br />   (setq        ent_data1 (entget ent_line1)<br />         ent_data2 (entget ent_line2)<br />         p1          (cdr (assoc 10 ent_data1))<br />         p2          (cdr (assoc 11 ent_data1))<br />         p3          (cdr (assoc 10 ent_data2))<br />         p4          (cdr (assoc 11 ent_data2))<br />         dis          (distance p1 p2)<br />         dis1          (distance p1 p3)<br />         dis2          (distance p2 p3)<br />         dis3          (distance p1 p4)<br />         dis4          (distance p2 p4)<br />   )<br />   (if (and<br />         (equal (+ dis dis1 dis2)<br />                (* 2.0 (max dis dis1 dis2))<br />                0.000001<br />         )<br />         (equal (+ dis dis3 dis4)<br />                (* 2.0 (max dis dis3 dis4))<br />                0.000001<br />         )<br />       )<br />     (progn<br />       (if (or (equal 90.0 (rtod (angle p1 p2)) 20)<br />               (equal 270 (rtod (angle p1 p2)) 20)<br />           )<br />         (setq pt<br />                (vl-sort        (list p1 p2 p3 p4)<br />                         (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))<br />                )<br />         )<br />         (setq pt<br />                (vl-sort        (list p1 p2 p3 p4)<br />                         (function (lambda (e1 e2) (< (car e1) (car e2))))<br />                )<br />         )<br />       )<br />       (setq p1              (cons 10 (car pt))<br />             p2              (cons 11 (nth 3 pt))<br />             ent_data1 (subst p1 (assoc 10 ent_data1) ent_data1)<br />             ent_data1 (subst p2 (assoc 11 ent_data1) ent_data1)<br />       )<br />       (entmod ent_data1)<br />     )<br />   )<br /> )<br /> (defun rtod (dat /)<br />   (* 180.0 (/ dat pi))<br /> )<br /> (princ "\n本程序由李蛟编写,功能是合并相同图层里的首尾相接或重叠的直线，用HBZHX调用。")<br /> (princ)<br />   [/FONT]<br />

longamei

很好用啊

aeo

50000个实体可以接受?!
多少时间.

光50000下(vla-GetBoundingBox (vlax-ename->vla-object ss1)时间就多少?
还有10万次的ssget

lijiao

不对，实际上没有那么多的次数，因为在处理过程中有很大一部分被合并了。
如果50000个实体全部是首尾相接，大约只有30000多次SSGET。
至于时间，可能有点夸张，因为我的机器配置比较高（图形工作站），速度还可以；另外，处理时间还与实体的位置关系有关。

eachy

最初由 lijiao 发布
[B]不对，实际上没有那么多的次数，因为在处理过程中有很大一部分被合并了。
如果50000个实体全部是首尾相接，大约只有30000多次SSGET。
至于时间，可能有点夸张，因为我的机器配置比较高（图形工作站），速度还可以?.. [/B]

这样修改下
[php]
(defun isOn (pt e)
  (equal (vlax-curve-getclosestpointto e pt)
         pt
         1e-5
  )
)
(defun hbline (ln1 ln2 / tf p0 p00 p1 p2 p3 p4)
  (setq        p1   (vlax-curve-getstartpoint ln1)
        p2   (vlax-curve-getendpoint ln1)
        p3   (vlax-curve-getstartpoint ln2)
        p4   (vlax-curve-getendpoint ln2)
        elst (entget ln1)
  )
  (if (or (ison p3 ln1)
          (ison p4 ln1)
          (ison p1 ln2)
          (ison p2 ln2)
      )
    (progn
      (setq pl (vl-sort        (list p1 p2 p3 p4)
                        '(lambda (e1 e2)
                           (if (equal (car e1) (car e2) 1e-5)
                             (< (cadr e1) (cadr e2))
                             (< (car e1) (car e2))
                           )
                         )
               )
      )
      (setq elst (subst (cons 10 (car pl)) (assoc 10 elst) elst)
            elst (subst (cons 11 (last pl)) (assoc 11 elst) elst)
      )
      (entmod elst)
      (entdel ln2)
    )
  )
  (princ)
)
(defun c:hbzhx (/ a ang e e1 el ep oldlst sp ss ssl)
  (if (setq ss (ssget '((0 . "line"))))
    (progn
      (command ".undo" "g")
      (setq ssl (sslength ss))
      (while (> ssl 0)
        (setq e          (ssname ss (setq ssl (1- ssl)))
              sp  (vlax-curve-getstartpoint e)
              ep  (vlax-curve-getendpoint e)
              ang (angle sp ep)
        )
        (if (>= ang pi)
          (setq ang (read (rtos (- ang pi) 2 4)))
          (setq ang (read (rtos ang 2 4)))
        )
        (if (not el)
          (setq el (list (list ang e)))
          (if (setq oldlst (assoc ang el))
            (setq el (subst (append oldlst (list e))
                            oldlst
                            el
                     )
            )
            (setq el (append el (list (list ang e))))
          )
        )
      )
      ;;将直线按角度划分
      (foreach i (mapcar 'cdr el)
        (if (> (length i) 1)
          (progn
            (while i
              (setq e1 (car i))
              (setq i (cdr i))
              (mapcar '(lambda (a)
                         (if (and (not (vlax-erased-p e1))
                                  (not (vlax-erased-p a))
                             )
                           (hbline e1 a)
                         )
                       )
                      i
              )
            )
          )
        )
      )
      (command ".undo" "e")
    )
  )
  (princ)
)
(princ)

[/php]

chenhang1203

不错，有点用

lijiao

[QUOTE]最初由 eachy 发布
[B][QUOTE]
刚测试了一下版主的代码和我提供的代码，处理实体16000个水平直线，我的代码耗时89秒，版主的代码耗时350秒。
我觉得提高效率的关键是如何减少循环次数。

eachy

最初由 lijiao 发布
[B][QUOTE]最初由 eachy 发布
[B][QUOTE]
刚测试了一下版主的代码和我提供的代码，处理实体16000个水平直线，我的代码耗时89秒，版主的代码耗时350秒。
我觉得提高效率的关键是如何减少循环次数。 [/B]

把你的测试图发上来看看，整 16000 个线也麻烦。

重新修改，比上次提高了很多。还可以在 合并部分优化，有的直接entdel，不用vl-sort。

2. 
   
3. ;;点是否在曲线上
   
4. (defun isOn (pt e)
   
5.   (equal (vlax-curve-getclosestpointto e pt)
   
6.          pt
   
7.          1e-5
   
8.   )
   
9. )
   
10. ;;合并两个直线，不考虑图层
    
11. (defun hbline (ln1 ln2 / elst pl tf p0 p00 p1 p2 p3 p4)
    
12.   (setq        p1   (vlax-curve-getstartpoint ln1)
    
13.         p2   (vlax-curve-getendpoint ln1)
    
14.         p3   (vlax-curve-getstartpoint ln2)
    
15.         p4   (vlax-curve-getendpoint ln2)
    
16.         elst (entget ln1)
    
17.   )
    
18.   (if (or (ison p3 ln1)
    
19.           (ison p4 ln1)
    
20.           (ison p1 ln2)
    
21.           (ison p2 ln2)
    
22.       )
    
23.     (progn
    
24.       (setq pl (vl-sort        (list p1 p2 p3 p4)
    
25.                         '(lambda (e1 e2)
    
26.                            (if (equal (car e1) (car e2) 1e-5)
    
27.                              (< (cadr e1) (cadr e2))
    
28.                              (< (car e1) (car e2))
    
29.                            )
    
30.                          )
    
31.                )
    
32.       )
    
33.       (setq elst (subst (cons 10 (car pl)) (assoc 10 elst) elst)
    
34.             elst (subst (cons 11 (last pl)) (assoc 11 elst) elst)
    
35.       )
    
36.       (entmod elst)
    
37.       (entdel ln2)
    
38.       ln2
    
39.     )
    
40.   )
    
41. )
    
42. (defun c:hbzhx (/ a ang e e1 el ep oldlst sp ss ssl l i1)
    
43.   (if (setq ss (ssget '((0 . "line"))))
    
44.     (progn
    
45.       (command ".undo" "g")
    
46.       ;;(command ".time" "r" "on" "d" "")
    
47.       (setq ssl (sslength ss))
    
48.       (while (> ssl 0)
    
49.         (setq e          (ssname ss (setq ssl (1- ssl)))
    
50.               sp  (vlax-curve-getstartpoint e)
    
51.               ep  (vlax-curve-getendpoint e)
    
52.               ang (angle sp ep)
    
53.         )
    
54.         (if (>= ang pi)
    
55.           (setq ang (read (rtos (- ang pi) 2 4)))
    
56.           (setq ang (read (rtos ang 2 4)))
    
57.         );精度
    
58.         (if (not el)
    
59.           (setq el (list (list ang e)))
    
60.           (if (setq oldlst (assoc ang el))
    
61.             (setq el (subst (append oldlst (list e))
    
62.                             oldlst
    
63.                             el
    
64.                      )
    
65.             )
    
66.             (setq el (append el (list (list ang e))))
    
67.           )
    
68.         )
    
69.       )                                        ;将直线按角度划分
    
70.       (setq el (mapcar 'cdr el))
    
71.       (foreach i el
    
72.         (if (> (length i) 1)
    
73.           (progn
    
74.             (while i
    
75.               (setq e1 (car i))
    
76.               (setq i  (cdr i)
    
77.                     i1 i
    
78.               )
    
79.               (while i1
    
80.                 (setq a         (car i1)
    
81.                       i1 (cdr i1)
    
82.                 )
    
83.                 (if (and (not (vlax-erased-p e1))
    
84.                          (not (vlax-erased-p a))
    
85.                     );这个判断似乎可以省掉
    
86.                   (if (setq l (hbline e1 a))
    
87.                     (setq i (vl-remove l i)) ;减少第一次的循环
    
88.                   )
    
89.                 )
    
90.               )
    
91.             )
    
92.           )
    
93.         )
    
94.       )
    
95.       ;;(command ".time" "d" "")
    
96.       (command ".undo" "e")
    
97.     )
    
98.   )
    
99.   (princ)
    
100. )
     
101. (princ)
     

<br /> ;;点是否在曲线上<br /> (defun isOn (pt e)<br />   (equal (vlax-curve-getclosestpointto e pt)<br />          pt<br />          1e-5<br />   )<br /> )<br /> ;;合并两个直线，不考虑图层<br /> (defun hbline (ln1 ln2 / elst pl tf p0 p00 p1 p2 p3 p4)<br />   (setq        p1   (vlax-curve-getstartpoint ln1)<br />         p2   (vlax-curve-getendpoint ln1)<br />         p3   (vlax-curve-getstartpoint ln2)<br />         p4   (vlax-curve-getendpoint ln2)<br />         elst (entget ln1)<br />   )<br />   (if (or (ison p3 ln1)<br />           (ison p4 ln1)<br />           (ison p1 ln2)<br />           (ison p2 ln2)<br />       )<br />     (progn<br />       (setq pl (vl-sort        (list p1 p2 p3 p4)<br />                         '(lambda (e1 e2)<br />                            (if (equal (car e1) (car e2) 1e-5)<br />                              (< (cadr e1) (cadr e2))<br />                              (< (car e1) (car e2))<br />                            )<br />                          )<br />                )<br />       )<br />       (setq elst (subst (cons 10 (car pl)) (assoc 10 elst) elst)<br />             elst (subst (cons 11 (last pl)) (assoc 11 elst) elst)<br />       )<br />       (entmod elst)<br />       (entdel ln2)<br />       ln2<br />     )<br />   )<br /> )<br /> (defun c:hbzhx (/ a ang e e1 el ep oldlst sp ss ssl l i1)<br />   (if (setq ss (ssget '((0 . "line"))))<br />     (progn<br />       (command ".undo" "g")<br />       ;;(command ".time" "r" "on" "d" "")<br />       (setq ssl (sslength ss))<br />       (while (> ssl 0)<br />         (setq e          (ssname ss (setq ssl (1- ssl)))<br />               sp  (vlax-curve-getstartpoint e)<br />               ep  (vlax-curve-getendpoint e)<br />               ang (angle sp ep)<br />         )<br />         (if (>= ang pi)<br />           (setq ang (read (rtos (- ang pi) 2 4)))<br />           (setq ang (read (rtos ang 2 4)))<br />         );精度<br />         (if (not el)<br />           (setq el (list (list ang e)))<br />           (if (setq oldlst (assoc ang el))<br />             (setq el (subst (append oldlst (list e))<br />                             oldlst<br />                             el<br />                      )<br />             )<br />             (setq el (append el (list (list ang e))))<br />           )<br />         )<br />       )                                        ;将直线按角度划分<br />       (setq el (mapcar 'cdr el))<br />       (foreach i el<br />         (if (> (length i) 1)<br />           (progn<br />             (while i<br />               (setq e1 (car i))<br />               (setq i  (cdr i)<br />                     i1 i<br />               )<br />               (while i1<br />                 (setq a         (car i1)<br />                       i1 (cdr i1)<br />                 )<br />                 (if (and (not (vlax-erased-p e1))<br />                          (not (vlax-erased-p a))<br />                     );这个判断似乎可以省掉<br />                   (if (setq l (hbline e1 a))<br />                     (setq i (vl-remove l i)) ;减少第一次的循环<br />                   )<br />                 )<br />               )<br />             )<br />           )<br />         )<br />       )<br />       ;;(command ".time" "d" "")<br />       (command ".undo" "e")<br />     )<br />   )<br />   (princ)<br /> )<br /> (princ)<br />

aeo

最初由 eachy 发布
[B][QUOTE]最初由 lijiao 发布
[B][QUOTE]最初由 eachy 发布
[B][QUOTE]
刚测试了一下版主的代码和我提供的代码，处理实体16000个水平直线，我的代码耗时89秒，版主的代码耗时350秒。
我觉得提高效率... [/B]

(if (>= ang pi)
          (setq ang (read (rtos (- ang pi) 2 4)))
          (setq ang (read (rtos ang 2 4)))
        );
我们对付float,一般是equal,你这样写其实是"精确"了
比如 1.22222 1.22225,不在一起.
   我曾经把1.22,用1.22 1.23 1.21三次assoc,速度不理想。
上面其实不要read, 字符用作索引更好.
  assoc 表长了也挺慢的,再subst ,其实找两遍.


(repeat  3(assoc "6" lst))  ;;lst中要没"6",不然"6"在开头就不好说了
  lst : 1000长的表(3遍，表中没这东东) 0.21秒
lst:  2000长的表 (3遍，表中没这东东) 0.8秒
次数多了，时间可观，表的长度是个关键.



还有合并两线，一重合就entmod,好象次数也多了，不过entmod速度很快.