[求助]如何生成闭合边界？

starlet2003

如何在图内使用Lisp来自动生成闭合边界？

生产中通过测图采集的房屋轮廓线存在较多的共用边线，节点咬合，即不存在悬挂点，这时如果使用BOUNDARY命令就可以针对每一栋房屋生成一个PLine的封闭边界，那么这里我的问题是如何通过lisp语言检索居民地的相应图层内所有的Pline和Line对象来自动生成相应的闭合边界呢？

也就是说怎么可以实现自动的BOUNDARY过程？

或者是自动为每一个封闭的区域自动生成一个闭合边界？

好像以前在AutoMap下通过构建拓扑可以实现这个目的。实现这个目的有怎样的思路呢？

Atsai

可以参考这里：
http://bbs.mjtd.com/thread-173390-1-1.html

tanjurun

好厉害，我看看是不是我要的

starlet2003

查了一些资料还是没有头绪..

abao2005

我也在找这个 ，有没有人知道啊

香田里浪人

;;边界轮廓线
;;最后转成pline线
(vl-load-com)
(defun c:bwx(/ viewpt maxmin spl2arc ss_add os cor qa ss n pt1 pt2 l_pt dis ent m)
  (defun viewpt(/ a b c d x)
    (setq b (getvar "viewsize") c (car (getvar "screensize")) d (cadr (getvar "screensize"))
          a (* b (/ c d)) x (setq x (getvar "viewctr")) x (trans x 1 2) c (list (- (car x)  (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
          d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) c (trans c 2 1) d (trans d 2 1)
    )
    (list c d)
  )
  (defun maxmin(lst / x n a b c d)
    (setq x (car lst) a (car x) b (cadr x) c (car x) d (cadr x) n 1)
    (repeat (max (- (length lst) 1) 0)
      (setq x (nth n lst) a (min a (car x)) b (min b (cadr x)) c (max c (car x)) d (max d (cadr x)))
      (setq n (1+ n))
    )
    (list (list a b) (list c d))
  )
  (defun spl2arc(ent / obj len num spt ept ss i pt1 pt2 pt3 s)
    (setq obj (vlax-ename->vla-object ent)
          len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
          num (1+ (fix (/ len dis)))
          num (if (= num 1) 2 num)
          spt (vlax-curve-getStartPoint obj)
          ept (vlax-curve-getEndPoint obj)
    )
    (command "_.divide" ent (* 2 num))
    (setvar "cecolor" "1")
    (setq ss (ssget "_p"))
    (if (equal spt ept)
      (setq i 1)
      (setq i 0)
    )
    (setq pt3 spt)
    (setq s (ssadd))
    (repeat num
      (setq pt2 (cdr (assoc 10 (entget (ssname ss i)))))
      (if (/= num (/ (+ i 2) 2))
        (setq pt1 (cdr (assoc 10 (entget (ssname ss (1+ i))))))
        (setq pt1 ept)
      )
      (command "_.arc" pt3 pt2 pt1)
      (ssadd (entlast) s)
      (setq pt3 pt1)
      (setq i (+ 2 i))
    )
    (command "_.erase" ss ent "")
    (setvar "cecolor" "188")
    s
  )
  (defun ss_add(s1 s2 / n)
    (setq n -1)
    (repeat (sslength s1)
      (ssadd (ssname s1 (setq n (1+ n))) s2)
    )
    s2
  )
  (prompt "\n请选择要生成边界轮廓线的所有对象（图块轮廓要闭合）：")
  (if (setq ss (ssget '((0 . "line,arc,circle,*polyline,spline,ellipse,insert"))))
    (progn
      (command "_.undo" "_be")
      (setq os (getvar "osmode")
            cor (getvar "cecolor")
            qa (getvar "qaflags")
      )
      (setvar "osmode" 0)
      (setvar "cmdecho" 0)
      (setq n -1)
      (repeat (sslength ss)
        (vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq n (1+ n)))) 'pt1 'pt2)
        (setq l_pt (append l_pt (list (vlax-safearray->list pt1) (vlax-safearray->list pt2))))
      )
      (setq l_pt (maxmin l_pt)
            pt1 (car l_pt)
            pt2 (cadr l_pt)
            dis (/ (distance pt1 pt2) 20)
            pt1 (polar pt1 (angle pt2 pt1) dis)
            pt2 (polar pt2 (angle pt1 pt2) dis)
      )
      (setq l_pt (maxmin (append (viewpt) (list pt1 pt2))))
      (command "_.zoom" "_w" (car l_pt) (cadr l_pt))
      (setvar "cecolor" "188")
      (command "_.rectang" pt1 pt2)
      (setq ent (entlast))
      (command "_.boundary" "_a" "_o" "_r" "_i" "_y" "_b" "_n" ent ss "" "" (polar pt1 (angle pt1 pt2) (/ dis 2)) "")
      (if (equal (entlast) ent)
        (progn
          (entdel ent)
          (prompt "\n没有边界轮廓线！")
        )
        (progn
          (entdel ent)
          (command "_.erase" (ssget "c" pt1 pt1 '((0 . "region") (62 . 188))) "")
          (setq m 0)
          (if (setq ss (ssget "x" '((0 . "region") (62 . 188))))
            (progn
              (command "_.union" ss "")
              (entmod (subst (cons 62 1) (cons 62 188) (entget (setq ent (entlast)))))
              (command "_.explode" ent)
              (setq ss (ssget "_p"))
              (if (= (cdr (assoc 0 (entget (ssname ss 0)))) "REGION")
                (progn
                  (setvar "qaflags" 1)
                  (command "_.explode" ss "")
                  (setq ss (ssget "_p"))
                )
              )
              (if (ssget "p" '((0 . "spline,ellipse")))
                (progn
                  (setq dis (abs (if (setq dis (getreal "\n请输入样条曲线或椭圆的取样距离：<10>")) dis 10.0)))
                  (if (= dis 0.0) (setq dis 10.0))
                )
              )
              (setq n -1)
              (repeat (sslength ss)
                (setq ent (ssname ss (setq n (1+ n)))
                      name (cdr (assoc 0 (entget ent)))
                )
                (if (or (= name "SPLINE") (= name "ELLIPSE"))
                  (progn
                    (ssdel ent ss)
                    (setq ss (ss_add (spl2arc ent) ss))
                    (setq n (1- n))
                  )
                )
              )
              (setq n -1)
              (while (setq ent (ssname ss (setq n (1+ n))))
                (if (entget ent)
                  (progn
                    (command "_.pedit" ent "_y" "_j" ss "" "")
                    (setq m (1+ m))
                  )
                )
              )
            )
          )
          (if (setq ss (ssget "x" '((0 . "*polyline") (62 . 188))))
            (progn
              (setq n -1)
              (repeat (sslength ss)
                (entmod (subst (cons 62 1) (cons 62 188) (entget (ssname ss (setq n (1+ n))))))
              )
              (setq m (+ m (sslength ss)))
            )
          )
          (if (= m 0)
            (prompt "\n没有边界轮廓线！")
            (prompt (strcat "\n生成" (itoa m) "条边界轮廓线！"))
          )
        )
      )
      (setvar "osmode" os)
      (setvar "cecolor" cor)
      (setvar "qaflags" qa)
      (command "_.undo" "_e")
    )
  )
  (princ)
)
(prompt "\n***边界轮廓线yad_outline***  YAD建筑")
(princ)

frogll

Gu_xl   版主的程序可以自动生成边界，http://bbs.mjtd.com/thread-80267-1-1.html，但是不支持多段线

zyhandw

frogll 发表于 2013-6-29 09:49
Gu_xl   版主的程序可以自动生成边界，http://bbs.mjtd.com/thread-80267-1-1.html，但是不支持多段线

不支持多段线还不好办？先转成直线就行了！

frogll

zyhandw 发表于 2013-6-29 11:29
不支持多段线还不好办？先转成直线就行了！

这个思路很好，谢谢

zyhandw

frogll 发表于 2013-7-1 12:48
这个思路很好，谢谢

呵呵，见笑了，笨人有笨办法

frogll

zyhandw 发表于 2013-7-1 14:03
呵呵，见笑了，笨人有笨办法

我就属于笨人，没有就想着加上，没变通啊，大侠提醒，思路豁然开朗！

香田里浪人

原作者名字忘了，程序如下，感觉如何，有兴趣不妨试一试。

(defun C:tt2 (/       *error* blk     obj     MinPt   MaxPt   hiden
              pt      pl      unnamed_block   isRus   tmp_blk adoc
              blks    lays    lay     oname   sel     csp     loc
              sc      ec      ret     DS      osm     iNSpT
             )

  (defun *error* (msg)
    (princ msg)
    (mapcar '(lambda (x) (vla-put-visible x :vlax-true)) hiden)
    (vla-endundomark adoc)
    (if (and tmp_blk
             (not (vlax-erased-p tmp_blk))
             (vlax-write-enabled-p tmp_blk)
        ) ;_ end of and
      (vla-erase tmp_blk)
    ) ;_ end of if
    (if osm
      (setvar "OSMODE" osm)
    ) ;_ end of if
    (foreach x loc (vla-put-lock x :vlax-true))
  ) ;_ end of defun
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq osm (getvar "OSMODE"))
  (if (zerop (getvar "WORLDUCS"))
    (progn (vl-cmdf "_.UCS" "") (vl-cmdf "_.Plan" ""))
  ) ;_ end of if
  (setq isRus (= (getvar "SysCodePage") "ANSI_1251"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        blks (vla-get-blocks adoc)
        lays (vla-get-layers adoc)
  ) ;_ end of setq
  (vla-startundomark adoc)
  (if isRus
    (princ "\n选择做一个轮廓的对象")
    (princ "\n选择做一个轮廓的对象")
  ) ;_ end of if
  (vlax-for lay lays
    (if (= (vla-get-lock lay) :vlax-true)
      (progn (vla-put-lock lay :vlax-false)
             (setq loc (cons lay loc))
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
  (if (setq sel (ssget))
    (progn
      (setq sel (ssnamex sel))
;;;    (setq iNSpT(apply 'mapcar (cons 'min
;;;     (mapcar 'cadr (apply 'append (mapcar '(lambda(x)(vl-remove-if-not 'listp x)) sel))))))
      (setq iNSpT '(0 0 0))
      (setq sel (mapcar 'vlax-ename->vla-object
                        (vl-remove-if 'listp (mapcar 'cadr sel))
                ) ;_ end of mapcar
      ) ;_ end of setq
      (setq csp (vla-objectidtoobject adoc (vla-get-ownerid (car sel))))
  ;;; (setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U"))
      (setq unnamed_block
             (vla-add (vla-get-blocks adoc)
                      (vlax-3d-point inspt)
                      "*U"
             ) ;_ end of vla-add
      ) ;_ end of setq
      (foreach x sel
        (setq oname (strcase (vla-get-objectname x)))
        (cond ((member oname
                       '("ACDBVIEWPORT"
                         "ACDBATTRIBUTEDEFINITION"
                         "ACDBMTEXT"
                         "ACDBTEXT"
                        )
               ) ;_ end of member
               nil
              )
              ((= oname "ACDBBLOCKREFERENCE")
               (vla-insertblock
                 unnamed_block
                 (vla-get-insertionpoint x)
                 (vla-get-name x)
                 (vla-get-xscalefactor x)
                 (vla-get-yscalefactor x)
                 (vla-get-zscalefactor x)
                 (vla-get-rotation x)
               ) ;_ end of vla-InsertBlock
               (setq blk (cons x blk))
              )
              (t (setq obj (cons x obj)))
        ) ;_ end of cond
      ) ;_foreach
      (setq lay (vla-item lays (getvar "CLAYER")))
      (if (= (vla-get-lock lay) :vlax-true)
        (progn (vla-put-lock lay :vlax-false)
               (setq loc (cons lay loc))
        ) ;_ end of progn
      ) ;_ end of if
      (if obj
        (progn (vla-copyobjects
                 (vla-get-activedocument (vlax-get-acad-object))
                 (vlax-make-variant
                   (vlax-safearray-fill
                     (vlax-make-safearray
                       vlax-vbobject
                       (cons 0 (1- (length obj)))
                     ) ;_ end of vlax-make-safearray
                     obj
                   ) ;_ end of vlax-safearray-fill
                 ) ;_ end of vlax-make-variant
                 unnamed_block
               ) ;_ end of vla-copyobjects
        ) ;_ end of progn
      ) ;_ end of if
      (setq obj (append obj blk))
      (if obj
        (progn
          (setq tmp_blk (vla-insertblock
                          csp
                          (vlax-3d-point inspt)
                          (vla-get-name unnamed_block)
                          1.0
                          1.0
                          1.0
                          0.0
                        ) ;_ end of vla-insertblock
          ) ;_ end of setq
          (vla-getboundingbox tmp_blk 'MinPt 'MaxPt)
          (setq MinPt (vlax-safearray->list MinPt)
                MaxPt (vlax-safearray->list MaxPt)
                DS    (max (distance MinPt (list (car MinPt) (cadr MaxPt)))
                           (distance MinPt (list (car MaxPt) (cadr MinPt)))
                      ) ;_ end of max
                DS    (* 0.2 DS)                  ;1/5
                DS    (max DS 10)
                MinPt (mapcar '- MinPt (list DS DS))
                MaxPt (mapcar '+ MaxPt (list DS DS))
          ) ;_ end of setq
          (lib:Zoom2Lst (list MinPt MaxPt))
          (setq sset (ssget "_C" MinPt MaxPt))
          (if sset
            (progn
              (setvar "OSMODE" 0)
              (setq hiden (mapcar 'vlax-ename->vla-object
                                  (vl-remove-if
                                    'listp
                                    (mapcar 'cadr (ssnamex sset))
                                  ) ;_ end of vl-remove-if
                          ) ;_ end of mapcar
                    hiden (vl-remove tmp_blk hiden)
              ) ;_ end of setq
              (mapcar '(lambda (x) (vla-put-visible x :vlax-false))
                      hiden
              ) ;_ end of mapcar
              (setq pt (mapcar '+ MinPt (list (* 0.5 DS) (* 0.5 DS))))
              (vl-cmdf "_.RECTANG" (trans MinPt 0 1) (trans MaxPt 0 1))
              (setq pl (vlax-ename->vla-object (entlast)))
              (setq sc (entlast))
              (if
                (vl-catch-all-error-p
                  (vl-catch-all-apply
                    '(lambda ()
                       (vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
                       (while (> (getvar "CMDACTIVE") 0) (command ""))
                     ) ;_ end of lambda
                  ) ;_ end of VL-CATCH-ALL-APPLY
                ) ;_ end of VL-CATCH-ALL-ERROR-P
                 (if isRus
                   (princ "\n这不是构造的轮廓")
                   (princ "\n这不是构造的轮廓")
                 ) ;_ end of if
              ) ;_ end of if
              (setq ec sc)
              (while (setq ec (entnext ec))
                (setq ret (cons (vlax-ename->vla-object ec) ret))
                )
                (setq ret (vl-remove pl ret))
              (mapcar '(lambda (x) (vla-erase x) (vlax-release-object x))
                      (list pl tmp_blk)
              ) ;_ end of mapcar
              (setq pl nil
                    tmp_blk nil
              ) ;_ end of setq
              (setq
                ret (mapcar '(lambda (x / mipt)
                               (vla-getboundingbox x 'MiPt nil)
                               (setq MiPt (vlax-safearray->list MiPt))
                               (list MiPt x)
                             ) ;_ end of lambda
                            ret
                    ) ;_ end of mapcar
              ) ;_ end of setq
              (setq ret (vl-sort ret
                                 '(lambda (e1 e2)
                                    (< (distance MinPt (car e1))
                                       (distance MinPt (car e2))
                                    ) ;_ end of <
                                  ) ;_ end of lambda
                        ) ;_ end of vl-sort
              ) ;_ end of setq
              (setq pl  (nth 1 ret)
                    ret (vl-remove pl ret)
              ) ;_ end of setq
              (mapcar 'vla-erase (mapcar 'cadr ret))
              (mapcar '(lambda (x) (vla-put-visible x :vlax-true))
                      hiden
              ) ;_ end of mapcar
              (foreach x loc (vla-put-lock x :vlax-true))
              (if pl
                (progn
                  (initget "Yes No")
                  (if
                    (= (getkword (if isRus
                                   "\n删除对象？ [Yes/No] <No> : "
                                   "\n删除对象？ [Yes/No] <No> : "
                                 ) ;_ end of if
                       ) ;_ end of getkword
                       "Yes"
                    ) ;_ end of =
                     (mapcar '(lambda (x)
                                (if (vlax-write-enabled-p x)
                                  (vla-erase x)
                                ) ;_ end of if
                              ) ;_ end of lambda
                             obj
                     ) ;_ end of mapcar
                  ) ;_ end of if
                ) ;_ end of progn
                (if isRus
                  (princ "\n这不是构造的轮廓")
                  (princ "\n这不是构造的轮廓")
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
      (vl-catch-all-apply
        '(lambda ()
           (mapcar 'vlax-release-object
                   (list unnamed_block tmp_blk csp blks lays)
           ) ;_ end of mapcar
         ) ;_ end of lambda
      ) ;_ end of VL-CATCH-ALL-APPLY
    ) ;_ end of progn
  ) ;_if not
  (foreach x loc (vla-put-lock x :vlax-true))
  (setvar "OSMODE" osm)
  (vla-endundomark adoc)
  (vlax-release-object adoc)
  (princ)
) ;_ end of defun
;;; ========== HELPER FUNCTION ==========================================
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
  (setq pt (trans pt 0 1))
  (setq VCTR  (getvar "VIEWCTR")
        Y_Len (getvar "VIEWSIZE")
        SSZ   (getvar "SCREENSIZE")
        X_Pix (car SSZ)
        Y_Pix (cadr SSZ)
        X_Len (* (/ X_Pix Y_Pix) Y_Len)
        Lc    (polar VCTR (dtr 180.0) (* 0.5 X_Len))
        Uc    (polar Lc 0.0 X_Len)
        Lc    (polar Lc (dtr 270.0) (* 0.5 Y_Len))
        Uc    (polar Uc (dtr 90.0) (* 0.5 Y_Len))
  ) ;_ end of setq
  (if (and (> (car pt) (car Lc))
           (< (car pt) (car Uc))
           (> (cadr pt) (cadr Lc))
           (< (cadr pt) (cadr Uc))
      ) ;_ end of and
    t
    nil
  ) ;_ end of if
) ;_ end of defun

(defun DTR (a) (* pi (/ a 180.0)))

(defun lib:pt_extents (vlist / tmp)

  (setq
    tmp (mapcar
          '(lambda (x) (vl-remove-if 'null x))
          (mapcar
            '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist))
            '(0 1 2)
          ) ;_ end of mapcar
        ) ;_ end of mapcar
  ) ;_setq

  (list (mapcar '(lambda (x) (apply 'min x)) tmp)
        (mapcar '(lambda (x) (apply 'max x)) tmp)
  ) ;_ end of list
) ;_defun

(defun lib:Zoom2Lst (vlist / bl tr Lst OS)

  (setq Lst (lib:pt_extents vlist)
        bl  (car Lst)
        tr  (cadr Lst)
  ) ;_ end of setq
  (if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
    (progn (setq OS (getvar "OSMODE"))
           (setvar "OSMODE" 0)
           (command "_.Zoom"
                    "_Window"
                    (trans bl 0 1)
                    (trans tr 0 1)
                    "_.Zoom"
                    "0.95x"
           ) ;_ end of command
           (setvar "OSMODE" OS)
           t
    ) ;_ end of progn
    NIL
  ) ;_ end of if
) ;_ end of defun