自动批量构宗-演示

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))

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