[求助]如何生成闭合边界？
<p>如何在图内使用Lisp来自动生成闭合边界？</p><p>生产中通过测图采集的房屋轮廓线存在较多的共用边线，节点咬合，即不存在悬挂点，这时如果使用BOUNDARY命令就可以针对每一栋房屋生成一个PLine的封闭边界，那么这里我的问题是如何通过lisp语言检索居民地的相应图层内所有的Pline和Line对象来自动生成相应的闭合边界呢？</p><p>也就是说怎么可以实现自动的BOUNDARY过程？</p><p>或者是自动为每一个封闭的区域自动生成一个闭合边界？</p><p>好像以前在AutoMap下通过构建拓扑可以实现这个目的。实现这个目的有怎样的思路呢？</p> frogll 发表于 2013-6-29 09:49 static/image/common/back.gifGu_xl 版主的程序可以自动生成边界，http://bbs.mjtd.com/thread-80267-1-1.html，但是不支持多段线
我曾仔细研究过G版的这个程序，不但多段线不行，交点也得自己打断，不方便。需要下大力气改造一番，前面需要做预处理，多段线要转成直线，还要对直线进行交点打断处理，这个步骤很费时间，最后才是进行拓扑操作！总之很费时间，800多条线处理了几十秒，要是几千条线时间无法忍受，还是去用G版的API吧！又快又好！ 可以参考这里：
http://bbs.mjtd.com/thread-173390-1-1.html 好厉害，我看看是不是我要的 <p>查了一些资料还是没有头绪..</p> 我也在找这个 ，有没有人知道啊 ;;边界轮廓线
;;最后转成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) Gu_xl 版主的程序可以自动生成边界，http://bbs.mjtd.com/thread-80267-1-1.html，但是不支持多段线 frogll 发表于 2013-6-29 09:49 static/image/common/back.gif
Gu_xl 版主的程序可以自动生成边界，http://bbs.mjtd.com/thread-80267-1-1.html，但是不支持多段线
不支持多段线还不好办？先转成直线就行了！ zyhandw 发表于 2013-6-29 11:29 static/image/common/back.gif
不支持多段线还不好办？先转成直线就行了！
这个思路很好，谢谢 frogll 发表于 2013-7-1 12:48 static/image/common/back.gif
这个思路很好，谢谢
呵呵，见笑了，笨人有笨办法 zyhandw 发表于 2013-7-1 14:03 static/image/common/back.gif
呵呵，见笑了，笨人有笨办法
我就属于笨人，没有就想着加上，没变通啊，大侠提醒，思路豁然开朗！ 原作者名字忘了，程序如下，感觉如何，有兴趣不妨试一试。
(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删除对象？ <No> : "
"\n删除对象？ <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