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

(BBPOLY)LINE,LWPOLYLINE生成拓扑边界区域

以前收集的,看到今天有朋友问这个,找出来分享给大家。
这个是拓扑由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 (carpl1)
                      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)
                  tot0.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)



**** Hidden Message *****

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

{:1_1:}{:1_1:}{:1_1:}{:1_1:}

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

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

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

学习一下 大师的思路

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

感谢楼主的程序
页: [1] 2 3 4 5 6 7 8 9 10
查看完整版本: (BBPOLY)LINE,LWPOLYLINE生成拓扑边界区域