发一个移动房屋内注记至右上角的程序，欢迎大家提意见

changyiran

做测绘内业的都一种体会，就是需要将房屋内注记（含房屋性质注记和层数注记）移到房屋右上角，很是费时间，鉴于此，本人开发了个小程序，欢迎大家提出宝贵意见。
在此，感谢G版在文本注记和坐标排序方面给予的热心帮助，再谢！！！

2. 
   
3. (vl-load-com)
   
4. (defun fjdb(en / x);返回轻量多段线的点表
   
5. (vl-remove-if'not
   
6.      (mapcar'(lambda(x)(if(=(car x)10)(cdr x)))(entget en));mapcar返回的是一个表，lambda构造一个匿名函数
   
7. )     
   
8. )
   
9. (defun pfx(zdzb el / HZJ JD JD1 JD2 QZJ XH);求多段线（直线段组成）任意转角的内角平分线
   
10.   (setq xh(vl-position zdzb el));求得指定坐标在多段线点表中的序号
    
11.   (cond((= 0 xh)(setq qzj(last el)hzj(cadr el)));分3种情况取得前转角和后转角坐标
    
12.        ((= (length el)(1+ xh))(setq qzj(nth (1- xh)el)hzj(car el)))
    
13.        (t(setq qzj(nth (1- xh)el)hzj(nth (1+ xh)el)))
    
14.   )
    
15.   (setq jd1(angle zdzb qzj)jd2(angle zdzb hzj));获得指定坐标至前转角和后转角的角度
    
16.   (setq jd(/ (+ jd1 jd2)2));获得角平分线的角度
    
17. )
    
18. (defun c:zjyd(/ DB DBJ EL1 EL2 EN FJ1 FJ2 FWZJEL FWZJEN J JJ NR NR1 NR2 SS SS1 SS2 X1 X2 Y1 Y2 ZJZB);房屋内注记性质移动
    
19.   (command"undo""m")
    
20.   (setq ss(ssget"x"'((0 . "lwpolyline")(8 . "jmd")(70 . 129)))j -1);建立房屋线选择集
    
21.   (repeat (sslength ss)
    
22.     (setq en(ssname ss(setq j(1+ j))))
    
23.     (setq db(fjdb en))
    
24.     (setq fj1(vl-sort-i db;按x从大到小排序
    
25.             (function
    
26.          (lambda (a b)
    
27.            (setq x1 (car a)
    
28.                  y1 (cadr a)
    
29.                  x2 (car b)
    
30.                  y2 (cadr b)
    
31.            )
    
32.            (if (equal x1 x2 1);当横坐标相差在一米内时认为两者相等
    
33.                (> y1 y2)
    
34.                (> x1 x2)
    
35.            )
    
36.          )
    
37.             )
    
38.            )
    
39.     fj2(vl-sort-i db;按y从大到小排序
    
40.             (function
    
41.          (lambda (a b)
    
42.            (setq x1 (car a)
    
43.                  y1 (cadr a)
    
44.                  x2 (car b)
    
45.                  y2 (cadr b)
    
46.            )
    
47.            (if (equal y1 y2 1)
    
48.                (> x1 x2)
    
49.                (> y1 y2)
    
50.            )
    
51.          )
    
52.             )
    
53.           )
    
54.     )
    
55.     (setq fj1(nth (car fj1) db)fj2(nth (car fj2) db));获取可能的东北角（俩房角）坐标
    
56.     (if (equal fj1 fj2)
    
57.         (setq dbj fj1);为同一房角时
    
58.         (progn
    
59.              (setq jj(angle fj1 fj2));取得房角1、房角2夹角（弧度）
    
60.         (if (and (> jj(* 0.75 pi))(< jj pi));获得东北角点坐标
    
61.         (setq dbj fj1)
    
62.         (setq dbj fj2)
    
63.      )
    
64.   )
    
65.     )
    
66.     (setq zjzb(polar dbj(pfx dbj db)3));获得注记坐标
    
67.     (setq ss1(ssget"cp"db'((1 . "..")(8 . "jmd"))));获得可能的房屋性质
    
68.     (setq ss2(ssget"cp"db'((1 . "~*[~.0-9]*")(8 . "jmd"))));获得可能的房屋层数
    
69.     (if ss1;存在房屋注记
    
70.         (progn
    
71.         (setq fwxzen(ssname ss1 0))
    
72.         (setq fwxzel(entget fwxzen))
    
73.         (if ss2
    
74.     (progn;存在房屋层数注记
    
75.       (setq csen(ssname ss2 0))
    
76.       (setq csel(entget csen))
    
77.       ;;;构造房屋性质和房屋层数图元表
    
78.       (setq fwxzel(list'(0 . "text")(assoc 1 fwxzel)(assoc 7 fwxzel)(assoc 40 fwxzel)(assoc 41 fwxzel)'(8 . "jmd")'(10 1 2)(list 11 (car zjzb)(cadr zjzb))'(72 . 2)'(73 . 2)))
    
79.       (setq csel(list'(0 . "text")(assoc 1 csel)(assoc 7 csel)(assoc 40 csel)(assoc 41 csel)'(8 . "jmd")'(10 1 2)(list 11 (car zjzb)(cadr zjzb))'(72 . 0)'(73 . 2)))
    
80.       (entmake fwxzel)
    
81.       (entmake csel)
    
82.       (entdel fwxzen);删除原注记
    
83.       (entdel csen)
    
84.     )
    
85.           (progn;房屋为1层即房屋内没有层数数字时   
    
86.       ;;;构造房屋性质图元表
    
87.       (setq fwxzel(list'(0 . "text")(assoc 1 fwxzel)(assoc 7 fwxzel)(assoc 40 fwxzel)(assoc 41 fwxzel)'(8 . "jmd")'(10 1 2)(list 11 (car zjzb)(cadr zjzb))'(72 . 1)'(73 . 2)))
    
88.       (entmake fwxzel)
    
89.       (entdel fwxzen)
    
90.     )
    
91.         )
    
92.   )
    
93.     )
    
94. )
    
95. (alert"运行完毕")
    
96. (princ)
    
97. )

<br /> (vl-load-com)<br /> (defun fjdb(en / x);返回轻量多段线的点表<br /> (vl-remove-if'not<br />      (mapcar'(lambda(x)(if(=(car x)10)(cdr x)))(entget en));mapcar返回的是一个表，lambda构造一个匿名函数<br /> )     <br /> )<br /> (defun pfx(zdzb el / HZJ JD JD1 JD2 QZJ XH);求多段线（直线段组成）任意转角的内角平分线<br />   (setq xh(vl-position zdzb el));求得指定坐标在多段线点表中的序号<br />   (cond((= 0 xh)(setq qzj(last el)hzj(cadr el)));分3种情况取得前转角和后转角坐标<br />        ((= (length el)(1+ xh))(setq qzj(nth (1- xh)el)hzj(car el)))<br />        (t(setq qzj(nth (1- xh)el)hzj(nth (1+ xh)el)))<br />   )<br />   (setq jd1(angle zdzb qzj)jd2(angle zdzb hzj));获得指定坐标至前转角和后转角的角度<br />   (setq jd(/ (+ jd1 jd2)2));获得角平分线的角度<br /> )<br /> (defun c:zjyd(/ DB DBJ EL1 EL2 EN FJ1 FJ2 FWZJEL FWZJEN J JJ NR NR1 NR2 SS SS1 SS2 X1 X2 Y1 Y2 ZJZB);房屋内注记性质移动<br />   (command"undo""m")<br />   (setq ss(ssget"x"'((0 . "lwpolyline")(8 . "jmd")(70 . 129)))j -1);建立房屋线选择集<br />   (repeat (sslength ss)<br />     (setq en(ssname ss(setq j(1+ j))))<br />     (setq db(fjdb en))<br />     (setq fj1(vl-sort-i db;按x从大到小排序<br />             (function<br />          (lambda (a b)<br />            (setq x1 (car a)<br />                  y1 (cadr a)<br />                  x2 (car b)<br />                  y2 (cadr b)<br />            )<br />            (if (equal x1 x2 1);当横坐标相差在一米内时认为两者相等<br />                (> y1 y2)<br />                (> x1 x2)<br />            )<br />          )<br />             )<br />            )<br />     fj2(vl-sort-i db;按y从大到小排序<br />             (function<br />          (lambda (a b)<br />            (setq x1 (car a)<br />                  y1 (cadr a)<br />                  x2 (car b)<br />                  y2 (cadr b)<br />            )<br />            (if (equal y1 y2 1)<br />                (> x1 x2)<br />                (> y1 y2)<br />            )<br />          )<br />             )<br />           )<br />     )<br />     (setq fj1(nth (car fj1) db)fj2(nth (car fj2) db));获取可能的东北角（俩房角）坐标<br />     (if (equal fj1 fj2)<br />         (setq dbj fj1);为同一房角时<br />         (progn<br />              (setq jj(angle fj1 fj2));取得房角1、房角2夹角（弧度）<br />         (if (and (> jj(* 0.75 pi))(< jj pi));获得东北角点坐标<br />         (setq dbj fj1)<br />         (setq dbj fj2)<br />      )<br />   )<br />     )<br />     (setq zjzb(polar dbj(pfx dbj db)3));获得注记坐标<br />     (setq ss1(ssget"cp"db'((1 . "..")(8 . "jmd"))));获得可能的房屋性质<br />     (setq ss2(ssget"cp"db'((1 . "~*[~.0-9]*")(8 . "jmd"))));获得可能的房屋层数<br />     (if ss1;存在房屋注记<br />         (progn<br />         (setq fwxzen(ssname ss1 0))<br />         (setq fwxzel(entget fwxzen))<br />         (if ss2<br />     (progn;存在房屋层数注记<br />       (setq csen(ssname ss2 0))<br />       (setq csel(entget csen))<br />       ;;;构造房屋性质和房屋层数图元表<br />       (setq fwxzel(list'(0 . "text")(assoc 1 fwxzel)(assoc 7 fwxzel)(assoc 40 fwxzel)(assoc 41 fwxzel)'(8 . "jmd")'(10 1 2)(list 11 (car zjzb)(cadr zjzb))'(72 . 2)'(73 . 2)))<br />       (setq csel(list'(0 . "text")(assoc 1 csel)(assoc 7 csel)(assoc 40 csel)(assoc 41 csel)'(8 . "jmd")'(10 1 2)(list 11 (car zjzb)(cadr zjzb))'(72 . 0)'(73 . 2)))<br />       (entmake fwxzel)<br />       (entmake csel)<br />       (entdel fwxzen);删除原注记<br />       (entdel csen)<br />     )<br />           (progn;房屋为1层即房屋内没有层数数字时    <br />       ;;;构造房屋性质图元表<br />       (setq fwxzel(list'(0 . "text")(assoc 1 fwxzel)(assoc 7 fwxzel)(assoc 40 fwxzel)(assoc 41 fwxzel)'(8 . "jmd")'(10 1 2)(list 11 (car zjzb)(cadr zjzb))'(72 . 1)'(73 . 2)))<br />       (entmake fwxzel)<br />       (entdel fwxzen)<br />     )<br />         )<br />   )<br />     )<br /> )<br /> (alert"运行完毕")<br /> (princ)<br /> )

langjs

真正的门外汉飘过……

changyiran

langjs 发表于 2012-4-26 17:56
真正的门外汉飘过……

大师严重了，涉及测绘的人比较少，故而大师对测绘不是很熟悉，但lisp方面还需要向大师学习。

fdb2007

取之于明用之于明，谢楼主分享

树櫴希德

将房屋内注记（含房屋性质注记和层数注记）移到房屋右上角到底是为了什么啊？难道图面好看些吗

yuanziyou

树櫴希德 发表于 2015-8-31 11:54
将房屋内注记（含房屋性质注记和层数注记）移到房屋右上角到底是为了什么啊？难道图面好看些吗

2007版图示好像是要求放右上角

暮雨寒阳

测试了一下，只有一部分能成功。是不是对房屋和注记有什么特殊要求？

wkq004

yuanziyou 发表于 2015-8-31 17:04
2007版图示好像是要求放右上角

图式要求都是注记在中间,宅基地有的县要求与宗地信息避让时,结构层数注在房屋的左下,右下等.

wkq004

yuanziyou 发表于 2015-8-31 17:04
2007版图示好像是要求放右上角

图式要求都是注记在中间,宅基地有的县要求与宗地信息避让时,结构层数注在房屋的左下,右下等.

l明了

你好，这个程序不太明白怎么使用，能麻烦您说明一下吗？不懂程序的人。