两条多段线的合并

lisp_beginner · 发表于 2018-11-28 09:25:04

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

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

Lisphk · 发表于 2018-11-28 09:33:55

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

marting · 发表于 2018-11-28 11:28:22

本帖最后由 marting 于 2018-11-28 11:31 编辑

试试

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

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

yoyoho · 发表于 2018-11-28 13:15:41

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

sicky111 · 发表于 2018-11-29 00:03:20

效率很高。

hn10183051 · 发表于 2019-1-10 13:47:10

论坛中好像看到过！

账号		自动登录	找回密码
密码			立即注册

[求助] 两条多段线的合并

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。