（BBPOLY）LINE,LWPOLYLINE生成拓扑边界区域

Lisphk · 发表于 2018-3-19 22:55:03

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

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

×

以前收集的，看到今天有朋友问这个，找出来分享给大家。
这个是拓扑由LINE和LWPOLYLINE组成的曲线的所有联通边界，只适合只有直线段的LWPOLYLINE

;; Batch BPoly - Lee Mac
;; Generates polylines for every region formed by a selection of lines & polylines
;; Restricted to LWPolylines with linear segments only.
;; Region generation based on a method by Stefan M.
(defun c:bbpoly ( / *error* big ent enx idx int lst pt1 pt2 rtn sel spc tmp tot val var vtx )
(defun *error* ( msg )
(foreach obj rtn
(if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj)))
(vla-delete obj)
)
)
(mapcar 'setvar var val)
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(LM:startundo (LM:acdoc))
(cond
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
(princ "\nCurrent layer locked.")
)
( (setq sel
(LM:ssget "\nSelect Lines & Polylines: "
(list
(list
'(-4 . "<OR")
'(0 . "LINE")
'(-4 . "<AND")
'(0 . "LWPOLYLINE")
'(-4 . "<NOT")
'(-4 . "<>")
'(42 . 0.0)
'(-4 . "NOT>")
'(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
)
)
(setq spc
(vlax-get-property (LM:acdoc)
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
)
(repeat (setq idx (sslength sel))
(if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx))))))))
(setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst))
(setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx)))
lst (append vtx lst)
)
)
)
(foreach pl1 lst
(setq pt1 (car pl1)
pt2 (cadr pl1)
)
(foreach pl2 lst
(if
(and
(not (equal pl1 pl2 1e-8))
(setq int (inters pt1 pt2 (car pl2) (cadr pl2)))
(not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1))
)
(setq pl1 (cons int pl1))
)
)
(setq rtn
(append
(mapcar
(function
(lambda ( a b )
(vla-addline spc
(vlax-3D-point a)
(vlax-3D-point b)
)
)
)
(setq pl1
(vl-sort pl1
(function
(lambda ( a b )
(< (distance pt1 a) (distance pt1 b))
)
)
)
)
(cdr pl1)
)
rtn
)
)
)
(setq var '(cmdecho peditaccept)
val (mapcar 'getvar var)
tot 0.0
)
(mapcar 'setvar var '(0 1))
(foreach reg (vlax-invoke spc 'addregion rtn)
(setq ent (entlast))
(command "_.pedit" "_m")
(apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode)))
(command "" "_j" "" "")
(if
(and
(not (eq ent (setq ent (entlast))))
(= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
)
(progn
(setq tmp (vlax-curve-getarea ent)
tot (+ tot tmp)
)
(if (< (car big) tmp)
(setq big (list tmp ent))
)
)
)
(vla-delete reg)
)
(if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
(entdel (cadr big))
)
(foreach obj rtn (vla-delete obj))
(mapcar 'setvar var val)
)
)
(LM:endundo (LM:acdoc))
(princ)
)
;; Start Undo - Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo - Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)

;; Batch BPoly  -  Lee Mac 
;; Generates polylines for every region formed by a selection of lines & polylines 
;; Restricted to LWPolylines with linear segments only. 
;; Region generation based on a method by Stefan M. 
 
(defun c:bbpoly ( / *error* big ent enx idx int lst pt1 pt2 rtn sel spc tmp tot val var vtx ) 
 
    (defun *error* ( msg ) 
        (foreach obj rtn 
            (if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj))) 
                (vla-delete obj) 
            ) 
        ) 
        (mapcar 'setvar var val) 
        (LM:endundo (LM:acdoc)) 
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) 
            (princ (strcat "\nError: " msg)) 
        ) 
        (princ) 
    ) 
 
    (LM:startundo (LM:acdoc)) 
    (cond 
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) 
            (princ "\nCurrent layer locked.") 
        ) 
        (   (setq sel 
                (LM:ssget "\nSelect Lines & Polylines: " 
                    (list 
                        (list 
                           '(-4 . "<OR") 
                               '(0 . "LINE") 
                               '(-4 . "<AND") 
                                   '(0 . "LWPOLYLINE") 
                                   '(-4 . "<NOT") 
                                       '(-4 . "<>") 
                                       '(42 . 0.0) 
                                   '(-4 . "NOT>") 
                               '(-4 . "AND>") 
                           '(-4 . "OR>") 
                            (if (= 1 (getvar 'cvport)) 
                                (cons 410 (getvar 'ctab)) 
                               '(410 . "Model") 
                            ) 
                        ) 
                    ) 
                ) 
            ) 
            (setq spc 
                (vlax-get-property (LM:acdoc) 
                    (if (= 1 (getvar 'cvport)) 
                        'paperspace 
                        'modelspace 
                    ) 
                ) 
            ) 
            (repeat (setq idx (sslength sel)) 
                (if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx)))))))) 
                    (setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst)) 
                    (setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx)) 
                          vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx))) 
                          lst (append vtx lst) 
                    ) 
                ) 
            ) 
            (foreach pl1 lst 
                (setq pt1 (car  pl1) 
                      pt2 (cadr pl1) 
                ) 
                (foreach pl2 lst 
                    (if 
                        (and 
                            (not (equal pl1 pl2 1e-8)) 
                            (setq int (inters pt1 pt2 (car pl2) (cadr pl2))) 
                            (not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1)) 
                        ) 
                        (setq pl1 (cons int pl1)) 
                    ) 
                ) 
                (setq rtn 
                    (append 
                        (mapcar 
                            (function 
                                (lambda ( a b ) 
                                    (vla-addline spc 
                                        (vlax-3D-point a) 
                                        (vlax-3D-point b) 
                                    ) 
                                ) 
                            ) 
                            (setq pl1 
                                (vl-sort pl1 
                                    (function 
                                        (lambda ( a b ) 
                                            (< (distance pt1 a) (distance pt1 b)) 
                                        ) 
                                    ) 
                                ) 
                            ) 
                            (cdr pl1) 
                        ) 
                        rtn 
                    ) 
                ) 
            ) 
            (setq var '(cmdecho peditaccept) 
                  val  (mapcar 'getvar var) 
                  tot  0.0 
            ) 
            (mapcar 'setvar var '(0 1)) 
            (foreach reg (vlax-invoke spc 'addregion rtn) 
                (setq ent (entlast)) 
                (command "_.pedit" "_m") 
                (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode))) 
                (command "" "_j" "" "") 
                (if 
                    (and 
                        (not (eq ent (setq ent (entlast)))) 
                        (= "LWPOLYLINE" (cdr (assoc 0 (entget ent)))) 
                    ) 
                    (progn 
                        (setq tmp (vlax-curve-getarea ent) 
                              tot (+ tot tmp) 
                        ) 
                        (if (< (car big) tmp) 
                            (setq big (list tmp ent)) 
                        ) 
                    ) 
                ) 
                (vla-delete reg) 
            ) 
            (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo 
                (entdel (cadr big)) 
            ) 
            (foreach obj rtn (vla-delete obj)) 
            (mapcar 'setvar var val) 
        ) 
    ) 
    (LM:endundo (LM:acdoc)) 
    (princ) 
) 
 
;; Start Undo  -  Lee Mac 
;; Opens an Undo Group. 
 
(defun LM:startundo ( doc ) 
    (LM:endundo doc) 
    (vla-startundomark doc) 
) 
 
;; End Undo  -  Lee Mac 
;; Closes an Undo Group. 
 
(defun LM:endundo ( doc ) 
    (while (= 8 (logand 8 (getvar 'undoctl))) 
        (vla-endundomark doc) 
    ) 
) 
 
;; Active Document  -  Lee Mac 
;; Returns the VLA Active Document Object 
 
(defun LM:acdoc nil 
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) 
    (LM:acdoc) 
) 
(vl-load-com) (princ)

游客，如果您要查看本帖隐藏内容请回复

sicky111 · 发表于 2018-3-20 00:05:19

沙发。谢谢分享。

yoyoho · 发表于 2018-3-20 05:17:30

谢谢分享程序！！！！

q3_2006 · 发表于 2018-3-20 06:13:39

真勤奋..学习了..

HLCAD · 发表于 2018-3-20 08:03:04

感谢楼主的程序！这个相当实用

scnjlwb · 发表于 2018-3-20 08:14:41

谢谢分享！

liunian0524 · 发表于 2018-3-20 08:35:51

感谢分享!!!

xinxirong · 发表于 2018-3-20 08:47:42

感谢楼主的程序！这个相当实用

sh_h · 发表于 2018-3-20 08:51:31

学习一下，谢谢！

zyclyl · 发表于 2018-3-20 09:01:13

看一看学一学，不过感觉没有地方用

dnbcgrass · 发表于 2018-3-20 09:16:50

谢谢分享，下来学习学习！

lrd1861 · 发表于 2018-3-20 09:25:16

marting · 发表于 2018-3-20 09:43:28

这类问题的本质都是把曲线在所有交点的地方打断，然后生成region, 再region->POLYLINE

pengfei2010 · 发表于 2018-3-20 11:26:15

学习一下大师的思路

8714454 · 发表于 2018-3-20 19:43:41

感谢楼主的程序

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

[每日一码] （BBPOLY）LINE,LWPOLYLINE生成拓扑边界区域

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