自动批量构宗-演示

llsheng_73

一直有个想法就是实现南方CASS的自动构宗，需要处理的是将宗地线内的相应的文字注记赋到线属性上去，另外还得调整宗地线的起点到西北角并且顺时针方向排列，至于宗地的注记倒不太用考虑，这个可以用CASS的重生成一次搞定
现在先发个演示图，一定的时候可能考虑放出程序

llsheng_73

难得这么久还有人关心批量宗地的问题，CASS自带那个确实头痛，从5.1到10.1没见明显改进

程序其实很简单，根据权属线所在图层选择闭合多段线，再选择它内部的权利人注记，根据设置的宗地号前边那一串，加上流水号，生成宗地线，生成宗地线可以重新绘制，也可以直接修改属性，但都需要调整它的起点为西北角

1. (defun mkdcl(str / dclF Fid dcl)
   
2.   (write-line(apply'strcat(if(listp str)str(list str)))
   
3.     (setq dclF(vl-filename-mktemp nil nil ".dcl")Fid(open dclF "w")))
   
4.   (close Fid)
   
5.   (setq dcl(load_dialog dclF))
   
6.   (vl-file-delete dclF)
   
7.   dcl)
   
8. (defun pldir(pt)
   
9.   (>(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))0))
   
10. (defun clockwise(pt / a i)
    
11.     (if(pldir pt)(setq pt(reverse pt)))
    
12.     (setq a(list(eval(cons'min(mapcar'car pt)))(eval(cons'max(mapcar'cadr pt))))
    
13.           a(cdar(vl-sort(mapcar'(lambda(x)(cons(distance x a)x))pt)(function(lambda(x y)(<(car x)(car y))))))
    
14.           i(vl-position a pt)
    
15.           pt(append(cdrnlst i pt)(midlstnm 0 i pt))))
    
16. (defun modplver(e pt / e2);;将多线段顶点坐标改为PT所定义的点
    
17.   (setq e(entget e)e2(member(assoc 90 e)e))
    
18.   (foreach x e2(setq e(vl-remove x e)))
    
19.   (setq e(append e(list(cons 90 (length pt))(assoc 70 e2)))
    
20.         e(if(assoc 43 e2)(append e(list(assoc 43 e2))))
    
21.         e(if(assoc 38 e2)(append e(list(assoc 38 e2))))
    
22.         e(if(assoc 39 e2)(append e(list(assoc 39 e2))))
    
23.         e2(member(assoc 10 e2)e2))
    
24.   (foreach x(mapcar'(lambda(x)(list(car x)(cadr x)))pt)
    
25.     (setq e(append e(list(cons 10 x)(cadr e2)(caddr e2)'(42 . 0)))e2(cddddr e2)))
    
26.   (entmod e))
    
27. (defun midlstnm(n m lst / a lst1)
    
28.     (setq a 0)
    
29.     (vl-member-if'(lambda(x)(if(<= n(setq a(1+ a))m)(setq lst1 (cons x lst1)))(if(> a m)t))lst)
    
30.     (reverse lst1))
    
31. (defun cdrnlst(n lst / a nlst)
    
32.     (setq a 0)
    
33.     (if(< n(length lst))(setq nlst(vl-member-if'(lambda(x)(setq a (1+ a))(< n a))lst)))nlst)
    
34. (defun strsplit(str splits / i a b)
    
35.     (while(<""str)
    
36.     (if(vl-remove'nil(mapcar'(lambda(x)(vl-string-search x str))splits))
    
37.       (setq i(car(vl-sort(vl-remove'nil(mapcar'(lambda(x)(if(setq l(vl-string-search x str))(cons l x)))splits))
    
38.        '(lambda(s1 s2)(<(car s1)(car s2)))))
    
39.       a(cons(substr str 1(car i))a)b(cons(cdr i)b)
    
40.       str(substr str(+(car i)(strlen(cdr i))1)))
    
41.       (setq a(cons str a)b(cons "" b)str"")))
    
42.   (reverse a))
    
43. (defun lst-(l1 l2)(foreach x l2(setq l1(vl-remove x l1)))l1)
    
44. (defun plxyz(e fuz / i p pt);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点
    
45.   (setq i(-(vlax-curve-getendparam e)(logand(cdr(assoc 70(entget e)))1)-1))
    
46.   (while(setq i(1- i)p(vlax-curve-getpointatparam e i))
    
47.     (setq pt(if(equal(car pt)p fuz)pt(cons p pt)))
    
48.     ))
    
49. (defun poinpl(p pt);;:点是否在指定点表内
    
50.   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
    
51. (defun centxt(ob / p1 p2)
    
52.   (vla-GetBoundingBox ob 'p1 'p2)
    
53.   (mapcar'*'(0.5 0.5)(apply'mapcar(cons'+(mapcar'safearray-value(list p1 p2))))))
    
54. (defun makepl(arg);;arg==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略
    
55.   (entmakex(append(mapcar'cons'(0 100 100 43 370 8 62 39 6)(append'("LWPOLYLINE""AcDbEntity""AcDbPolyline")(cddr arg)))
    
56.                   (cons(cons 90(length(car arg)))(cons(cons 70(if(cadr arg)(cadr arg)0))(mapcar'(lambda(x)(cons 10 x))(car arg)))))))
    
57. (defun C:plzd(/ LYS lYQS DCL QLRS QZ ZDS ss i dcl ctl)
    
58.   (setq *doc(vla-get-ActiveDocument (vlax-get-acad-object))
    
59.         LYS(OBJITEMS *doc 'LAYERS 'NAME)
    
60.         lYQS(vl-remove-if-not'(lambda(x)(ssget"X"(mapcar'cons'(0 8 -4 70)(list"*polyline"x"&"1'(("SOUTH"))))))LYS)
    
61.         LYS(vl-remove-if-not'(lambda(x)(ssget"X"(mapcar'cons'(0 8)(list"*text"x))))LYS)
    
62.         dcl(mkdcl'("ZDSZ:dialog{label=\"～批量宗地基本设置～\";"
    
63.                    ":row{:popup_list{label=\"权属线图层\";key=\"LZD\";}:button{label=\"..\";key=\"GETX\";}}"
    
64.                    ":row{:popup_list{label=\"权利人图层\";key=\"QLR\";}:button{label=\"..\";key=\"GETT\";}}"
    
65.                    ":row{:column{:edit_box{label=\"村级行政代码\";key=\"DM\";}"
    
66.                    ":row{:edit_box{label=\"默认地类\";key=\"DL\";value=\"0702\";edit_width=3;}"
    
67.                    ":edit_box{label=\"前辍\";key=\"QZ\";value=\"JC\";edit_width=3;}}}"
    
68.                    ":column{:button{key=\"GO\";label=\"确定\";is_default=true;}"
    
69.                    ":button{key=\"ESC\";label=\"取消\";is_cancel=true;}}}}")))
    
70.   (REGAPP"south")(REGAPP"YBDJH")(SETLAYER *doc"JZD"1)
    
71.   (and lYQS LYS(setq ctl 3)
    
72.        (while(> ctl 1)(new_dialog"ZDSZ"dcl)
    
73.          (start_list "LZD")(mapcar 'add_list lYQS)(end_list)(set_tile"LZD"(itoa(if(member LZD lyqs)(vl-position LZD lyqs)0)))
    
74.          (start_list "QLR")(mapcar 'add_list LYS)(end_list)(set_tile"QLR"(itoa(if(member qlr LYS)(vl-position qlr LYS)0)))
    
75.          (set_tile"DM"(if DM DM""))(action_tile"GETX""(done_dialog 2)")(action_tile"GETT""(done_dialog 3)")
    
76.          (action_tile"GO""(setq LZD(nth(atoi(get_tile \"LZD\"))lYQS)QLR(nth(atoi(get_tile \"QLR\"))LYS)DM(get_tile \"DM\")DL(get_tile \"DL\")QZ(get_tile \"QZ\"))(done_dialog 1)")
    
77.          (cond((=(setq ctl(start_dialog))2)
    
78.                (if(setq e(getbypoint(getpoint"选择宗地线")(mapcar'cons'(0 8 -4 70)(list"lwpolyline"(apply'strcat(mapcar'(lambda(x)(strcat x","))lYQS))"&"1))>))
    
79.                  (setq LZD(cdr(assoc 8(entget e))))))
    
80.               ((= ctl 3)
    
81.                (if(setq e(ssget":E:S"(mapcar'cons'(0 8)(list"text"(apply'strcat(mapcar'(lambda(x)(strcat x","))LYS))))))
    
82.                  (setq QLR(cdr(assoc 8(entget(ssname e 0)))))))
    
83.              ((= ctl 1)
    
84.               (setq QLRS(ssnamex(ssget"X"(mapcar'cons'(0 8)(list"*text"QLR"&"1))))
    
85.                     ZDS(mapcar'cadr(ssnamex(ssget"X"(mapcar'cons'(0 8 -4 70)(list"*polyline"LZD"&"1'(("SOUTH")))))))
    
86.                     zds(mapcar'(lambda(x)(nth x zds))(vl-sort-i(mapcar'(lambda(x)(vla-get-Area(vlax-ename->vla-object x)))zds)'>)))
    
87.               (grtext -2(strcat"【权属线"(itoa(length ZDS))"  权利人"(itoa(length QLRS))"】"))
    
88.               (setq ss(ssadd)QLRS(mapcar'(lambda(x)(setq x(cadr x))(list(centxt(vlax-ename->vla-object x))(CDR(ASSOC 1(ENTGET x)))))QLRS)i 0)
    
89.               (foreach x zds
    
90.                 (setq pt(plxyz x 0)y(vl-some'(lambda(x)(if(poinpl(car x)pt)(setq y x)))QLRS))
    
91.                 (if y(setq QLRS(vl-remove y QLRS)y(STRSPLIT(cadr y)'("-"))
    
92.                            y(adddata(makepl(list(clockwise pt)1 0.15 0"JZD"1))
    
93.                                     (list(list"SOUTH""300000"(strcat DM QZ(if(=(length y)3)(strcat(myitoa(atoi(car y))2)(myitoa(atoi(cadr y))3))
    
94.                                                                             (myitoa(setq i(1+ i))5)))(last y)DL))))
    
95.                 (ssadd x ss)))))))
    
96.   (sssetfirst'nil ss))

(defun mkdcl(str / dclF Fid dcl)<br />   (write-line(apply'strcat(if(listp str)str(list str)))<br />     (setq dclF(vl-filename-mktemp nil nil ".dcl")Fid(open dclF "w")))<br />   (close Fid)<br />   (setq dcl(load_dialog dclF))<br />   (vl-file-delete dclF)<br />   dcl)<br /> (defun pldir(pt)<br />   (>(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))0))<br /> (defun clockwise(pt / a i)<br />     (if(pldir pt)(setq pt(reverse pt)))<br />     (setq a(list(eval(cons'min(mapcar'car pt)))(eval(cons'max(mapcar'cadr pt))))<br />           a(cdar(vl-sort(mapcar'(lambda(x)(cons(distance x a)x))pt)(function(lambda(x y)(<(car x)(car y))))))<br />           i(vl-position a pt)<br />           pt(append(cdrnlst i pt)(midlstnm 0 i pt))))<br /> (defun modplver(e pt / e2);;将多线段顶点坐标改为PT所定义的点<br />   (setq e(entget e)e2(member(assoc 90 e)e))<br />   (foreach x e2(setq e(vl-remove x e)))<br />   (setq e(append e(list(cons 90 (length pt))(assoc 70 e2)))<br />         e(if(assoc 43 e2)(append e(list(assoc 43 e2))))<br />         e(if(assoc 38 e2)(append e(list(assoc 38 e2))))<br />         e(if(assoc 39 e2)(append e(list(assoc 39 e2))))<br />         e2(member(assoc 10 e2)e2))<br />   (foreach x(mapcar'(lambda(x)(list(car x)(cadr x)))pt)<br />     (setq e(append e(list(cons 10 x)(cadr e2)(caddr e2)'(42 . 0)))e2(cddddr e2)))<br />   (entmod e))<br /> (defun midlstnm(n m lst / a lst1)<br />     (setq a 0)<br />     (vl-member-if'(lambda(x)(if(<= n(setq a(1+ a))m)(setq lst1 (cons x lst1)))(if(> a m)t))lst)<br />     (reverse lst1))<br /> (defun cdrnlst(n lst / a nlst)<br />     (setq a 0)<br />     (if(< n(length lst))(setq nlst(vl-member-if'(lambda(x)(setq a (1+ a))(< n a))lst)))nlst)<br /> (defun strsplit(str splits / i a b)<br />     (while(<""str)<br />     (if(vl-remove'nil(mapcar'(lambda(x)(vl-string-search x str))splits))<br />       (setq i(car(vl-sort(vl-remove'nil(mapcar'(lambda(x)(if(setq l(vl-string-search x str))(cons l x)))splits))<br />        '(lambda(s1 s2)(<(car s1)(car s2)))))<br />       a(cons(substr str 1(car i))a)b(cons(cdr i)b)<br />       str(substr str(+(car i)(strlen(cdr i))1)))<br />       (setq a(cons str a)b(cons "" b)str"")))<br />   (reverse a))<br /> (defun lst-(l1 l2)(foreach x l2(setq l1(vl-remove x l1)))l1)<br /> (defun plxyz(e fuz / i p pt);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点<br />   (setq i(-(vlax-curve-getendparam e)(logand(cdr(assoc 70(entget e)))1)-1))<br />   (while(setq i(1- i)p(vlax-curve-getpointatparam e i))<br />     (setq pt(if(equal(car pt)p fuz)pt(cons p pt)))<br />     ))<br /> (defun poinpl(p pt);;:点是否在指定点表内<br />   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))<br /> (defun centxt(ob / p1 p2)<br />   (vla-GetBoundingBox ob 'p1 'p2)<br />   (mapcar'*'(0.5 0.5)(apply'mapcar(cons'+(mapcar'safearray-value(list p1 p2))))))<br /> (defun makepl(arg);;arg==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略<br />   (entmakex(append(mapcar'cons'(0 100 100 43 370 8 62 39 6)(append'("LWPOLYLINE""AcDbEntity""AcDbPolyline")(cddr arg)))<br />                   (cons(cons 90(length(car arg)))(cons(cons 70(if(cadr arg)(cadr arg)0))(mapcar'(lambda(x)(cons 10 x))(car arg)))))))<br /> (defun C:plzd(/ LYS lYQS DCL QLRS QZ ZDS ss i dcl ctl)<br />   (setq *doc(vla-get-ActiveDocument (vlax-get-acad-object))<br />         LYS(OBJITEMS *doc 'LAYERS 'NAME)<br />         lYQS(vl-remove-if-not'(lambda(x)(ssget"X"(mapcar'cons'(0 8 -4 70)(list"*polyline"x"&"1'(("SOUTH"))))))LYS)<br />         LYS(vl-remove-if-not'(lambda(x)(ssget"X"(mapcar'cons'(0 8)(list"*text"x))))LYS)<br />         dcl(mkdcl'("ZDSZ:dialog{label=\"～批量宗地基本设置～\";"<br />                    ":row{:popup_list{label=\"权属线图层\";key=\"LZD\";}:button{label=\"..\";key=\"GETX\";}}"<br />                    ":row{:popup_list{label=\"权利人图层\";key=\"QLR\";}:button{label=\"..\";key=\"GETT\";}}"<br />                    ":row{:column{:edit_box{label=\"村级行政代码\";key=\"DM\";}"<br />                    ":row{:edit_box{label=\"默认地类\";key=\"DL\";value=\"0702\";edit_width=3;}"<br />                    ":edit_box{label=\"前辍\";key=\"QZ\";value=\"JC\";edit_width=3;}}}"<br />                    ":column{:button{key=\"GO\";label=\"确定\";is_default=true;}"<br />                    ":button{key=\"ESC\";label=\"取消\";is_cancel=true;}}}}")))<br />   (REGAPP"south")(REGAPP"YBDJH")(SETLAYER *doc"JZD"1)<br />   (and lYQS LYS(setq ctl 3)<br />        (while(> ctl 1)(new_dialog"ZDSZ"dcl)<br />          (start_list "LZD")(mapcar 'add_list lYQS)(end_list)(set_tile"LZD"(itoa(if(member LZD lyqs)(vl-position LZD lyqs)0)))<br />          (start_list "QLR")(mapcar 'add_list LYS)(end_list)(set_tile"QLR"(itoa(if(member qlr LYS)(vl-position qlr LYS)0)))<br />          (set_tile"DM"(if DM DM""))(action_tile"GETX""(done_dialog 2)")(action_tile"GETT""(done_dialog 3)")<br />          (action_tile"GO""(setq LZD(nth(atoi(get_tile \"LZD\"))lYQS)QLR(nth(atoi(get_tile \"QLR\"))LYS)DM(get_tile \"DM\")DL(get_tile \"DL\")QZ(get_tile \"QZ\"))(done_dialog 1)")<br />          (cond((=(setq ctl(start_dialog))2)<br />                (if(setq e(getbypoint(getpoint"选择宗地线")(mapcar'cons'(0 8 -4 70)(list"lwpolyline"(apply'strcat(mapcar'(lambda(x)(strcat x","))lYQS))"&"1))>))<br />                  (setq LZD(cdr(assoc 8(entget e))))))<br />               ((= ctl 3)<br />                (if(setq e(ssget":E:S"(mapcar'cons'(0 8)(list"text"(apply'strcat(mapcar'(lambda(x)(strcat x","))LYS))))))<br />                  (setq QLR(cdr(assoc 8(entget(ssname e 0)))))))<br />              ((= ctl 1)<br />               (setq QLRS(ssnamex(ssget"X"(mapcar'cons'(0 8)(list"*text"QLR"&"1))))<br />                     ZDS(mapcar'cadr(ssnamex(ssget"X"(mapcar'cons'(0 8 -4 70)(list"*polyline"LZD"&"1'(("SOUTH")))))))<br />                     zds(mapcar'(lambda(x)(nth x zds))(vl-sort-i(mapcar'(lambda(x)(vla-get-Area(vlax-ename->vla-object x)))zds)'>)))<br />               (grtext -2(strcat"【权属线"(itoa(length ZDS))"  权利人"(itoa(length QLRS))"】"))<br />               (setq ss(ssadd)QLRS(mapcar'(lambda(x)(setq x(cadr x))(list(centxt(vlax-ename->vla-object x))(CDR(ASSOC 1(ENTGET x)))))QLRS)i 0)<br />               (foreach x zds<br />                 (setq pt(plxyz x 0)y(vl-some'(lambda(x)(if(poinpl(car x)pt)(setq y x)))QLRS))<br />                 (if y(setq QLRS(vl-remove y QLRS)y(STRSPLIT(cadr y)'("-"))<br />                            y(adddata(makepl(list(clockwise pt)1 0.15 0"JZD"1))<br />                                     (list(list"SOUTH""300000"(strcat DM QZ(if(=(length y)3)(strcat(myitoa(atoi(car y))2)(myitoa(atoi(cadr y))3))<br />                                                                             (myitoa(setq i(1+ i))5)))(last y)DL))))<br />                 (ssadd x ss)))))))<br />   (sssetfirst'nil ss))

这是后来修改过的，改了多少次记不得了，也不敢把现在的发出来，发现在的估计有人要和我说聊斋。。。。
现在用的关于西北角点的确定是修改了的，其它的大同小异，也就界面不一样

llsheng_73

夏思恩 发表于 2018-2-8 08:31
地类最好也跟人名一样在图上提取，再把土地坐落，身份证，电话等挂接上就完美了，哈哈

地类,土地坐落，身份证，电话等信息全部放到图上的话，图面负荷太重，数据出了问题也不方便修改
这些信息可以放到EXCEL表里边，批量生成宗地后，导出宗地线的句柄、宗地号、户主名等到EXCEL表，再把其它相关信息通过EXCEL表挂接上，然后反导入到图上是可以的，在前两年已经这样用了，不过没有包含土地坐落，身份证，电话等信息而是一些别的信息，但方法是类似的

夏思恩

地类最好也跟人名一样在图上提取，再把土地坐落，身份证，电话等挂接上就完美了，哈哈

cuyongping

支持，直到顶出源码！呵呵

yoyoho

支持，不错喔!

lrd1861

虽然用不到 也要顶  顶出程序 顶出源码

陈亚娣

支持,支持

蓝图测绘

这个一定要支持

杜阳

搞测绘的人不是很多啊啊  来支持  顶上去

tianyi1230

测量的人确实用的到，只是明经论坛的测量人不多，其实这个插件用过CASS的都知道其价值，顶楼主

hhh454

这个必须顶了，学习呀，

llsheng_73

CASS绘制直接绘制宗地的麻烦在于：一是必须一次绘完，这就绘给绘制过程增加工作量和出错机率，虽然用多线段转为权属线可以避免，但总给人感觉怪怪的，另外属性的重复输入还是无法避免，所以就弄了上边这个来提高工效