两条多段线的合并

lisp_beginner

如上图，有什么思路或者代码，谢谢！

Lisphk

思路，转面域，面域求并，炸开面域，JOIN成多段线

marting

试试

1. (defun c:PLUNION (/ *error* i lst ms r1 reg ss sysvar prop)
   
2.   (or acDoc
   
3.       (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
   
4.   )
   
5.   (setq        ms (vlax-get acDoc
   
6.                      (if (= 1 (getvar 'cvport))
   
7.                        'paperspace
   
8.                        'modelspace
   
9.                      )
   
10.            )
    
11.   )
    
12.   (vla-startundomark acDoc)
    
13.   (setq sysvar (mapcar 'getvar '(peditaccept draworderctl cmdecho)))
    
14. 
    
15.   (defun *error* (msg)
    
16.     (and
    
17.       msg
    
18.       (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
    
19.       (princ (strcat "\nError: " msg))
    
20.     )
    
21.     (mapcar 'setvar '(peditaccept draworderctl cmdecho) sysvar)
    
22.     (vla-endundomark acDoc)
    
23.     (princ)
    
24.   )
    
25. 
    
26.   (if
    
27.     (setq ss (ssget ":L" '((0 . "LWPOLYLINE") (-4 . ">") (90 . 2))))
    
28.      (progn
    
29.        (repeat (setq i (sslength ss))
    
30.          (setq lst
    
31.                 (cons (vlax-ename->vla-object (ssname ss (setq i (1- i))))
    
32.                       lst
    
33.                 )
    
34.          )
    
35.        )
    
36.        (foreach x lst (vla-put-closed x :vlax-true))
    
37.        (setq prop (mapcar '(lambda (p) (vlax-get (car lst) p))
    
38.                           '(Layer LineType Color)
    
39.                   )
    
40.        )
    
41.        (setq reg (vlax-invoke ms 'AddRegion lst))
    
42.        (foreach x lst (vla-delete x))
    
43.        (setq r1 (car reg))
    
44.        (foreach x (cdr reg) (vlax-invoke r1 'boolean acunion x))
    
45.        (mapcar '(lambda (p v) (vlax-put r1 p v))
    
46.                '(Layer LineType Color)
    
47.                prop
    
48.        )
    
49.        (setq lst (apply
    
50.                    'append
    
51.                    (mapcar
    
52.                      '(lambda (a)
    
53.                         (if
    
54.                           (listp a)
    
55.                            (mapcar 'vlax-vla-object->ename a)
    
56.                            (list (vlax-vla-object->ename a))
    
57.                         )
    
58.                       )
    
59.                      (mapcar
    
60.                        '(lambda        (e / p)
    
61.                           (if (eq (vla-get-objectname e) "AcDbRegion")
    
62.                             (progn
    
63.                               (setq p (vlax-invoke e 'explode))
    
64.                               (vla-delete e)
    
65.                               p
    
66.                             )
    
67.                             e
    
68.                           )
    
69.                         )
    
70.                        (vlax-invoke r1 'explode)
    
71.                      )
    
72.                    )
    
73.                  )
    
74.        )
    
75.        (vla-delete r1)
    
76.        (setq ss (ssadd))
    
77.        (foreach x lst (ssadd x ss))
    
78.        (mapcar 'setvar
    
79.                '(peditaccept draworderctl cmdecho)
    
80.                '(1 0 0)
    
81.        )
    
82.        (command "_pedit" "_m" ss "" "_j" "" "")
    
83.      )
    
84.   )
    
85.   (*error* nil)
    
86.   (princ)
    
87. )
    
88. 
    

(defun c:PLUNION (/ *error* i lst ms r1 reg ss sysvar prop)<br />   (or acDoc<br />       (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))<br />   )<br />   (setq        ms (vlax-get acDoc<br />                      (if (= 1 (getvar 'cvport))<br />                        'paperspace<br />                        'modelspace<br />                      )<br />            )<br />   )<br />   (vla-startundomark acDoc)<br />   (setq sysvar (mapcar 'getvar '(peditaccept draworderctl cmdecho)))<br /> <br />   (defun *error* (msg)<br />     (and<br />       msg<br />       (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))<br />       (princ (strcat "\nError: " msg))<br />     )<br />     (mapcar 'setvar '(peditaccept draworderctl cmdecho) sysvar)<br />     (vla-endundomark acDoc)<br />     (princ)<br />   )<br /> <br />   (if<br />     (setq ss (ssget ":L" '((0 . "LWPOLYLINE") (-4 . ">") (90 . 2))))<br />      (progn<br />        (repeat (setq i (sslength ss))<br />          (setq lst<br />                 (cons (vlax-ename->vla-object (ssname ss (setq i (1- i))))<br />                       lst<br />                 )<br />          )<br />        )<br />        (foreach x lst (vla-put-closed x :vlax-true))<br />        (setq prop (mapcar '(lambda (p) (vlax-get (car lst) p))<br />                           '(Layer LineType Color)<br />                   )<br />        )<br />        (setq reg (vlax-invoke ms 'AddRegion lst))<br />        (foreach x lst (vla-delete x))<br />        (setq r1 (car reg))<br />        (foreach x (cdr reg) (vlax-invoke r1 'boolean acunion x))<br />        (mapcar '(lambda (p v) (vlax-put r1 p v))<br />                '(Layer LineType Color)<br />                prop<br />        )<br />        (setq lst (apply<br />                    'append<br />                    (mapcar<br />                      '(lambda (a)<br />                         (if<br />                           (listp a)<br />                            (mapcar 'vlax-vla-object->ename a)<br />                            (list (vlax-vla-object->ename a))<br />                         )<br />                       )<br />                      (mapcar<br />                        '(lambda        (e / p)<br />                           (if (eq (vla-get-objectname e) "AcDbRegion")<br />                             (progn<br />                               (setq p (vlax-invoke e 'explode))<br />                               (vla-delete e)<br />                               p<br />                             )<br />                             e<br />                           )<br />                         )<br />                        (vlax-invoke r1 'explode)<br />                      )<br />                    )<br />                  )<br />        )<br />        (vla-delete r1)<br />        (setq ss (ssadd))<br />        (foreach x lst (ssadd x ss))<br />        (mapcar 'setvar<br />                '(peditaccept draworderctl cmdecho)<br />                '(1 0 0)<br />        )<br />        (command "_pedit" "_m" ss "" "_j" "" "")<br />      )<br />   )<br />   (*error* nil)<br />   (princ)<br /> )<br /> <br />

yoyoho

谢谢! marting 分享程序!!!!

sicky111

效率很高。

hn10183051

论坛中好像看到过！