设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 自动批量构宗-演示
1234
返回列表 发新帖
楼主: llsheng_73

[测绘] 自动批量构宗-演示

  [复制链接]
llsheng_73
 楼主| 发表于 2022-1-4 20:07 | 显示全部楼层
本帖最后由 llsheng_73 于 2022-1-4 20:11 编辑

难得这么久还有人关心批量宗地的问题，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))


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

使用道具 举报

1234
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-5-4 08:38 , Processed in 0.383802 second(s), 19 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表