标批量注面积，面积随图片变换而变换

香田里浪人

bai2000 发表于 2015-8-22 12:28
标注的字体大小怎么改，标注字体能在单独层上最好

作者已经设置标注字体在mj层，字体高度为2，另外作者标注面积单位是“亩”，如果要换算为“平方米”可把
666.6667去掉。

longer1000

chbddzx12

看看~~~~~~~~~~~~~~~~~~~~~~

chbddzx12

好牛。。。。。。。。。。。。。。

树櫴希德

2. (vl-load-com)
   
3. (defun c:c1 (/)
   
4.   (setq e (car (entsel "\n 请选择多边形==>>  ")))
   
5.   (setq e_obj (vlax-ename->vla-object e))
   
6.   (vla-getboundingbox e_obj 'minpt 'maxpt)
   
7.   (setq p1 (vlax-safearray->list minpt))
   
8.   (setq p2 (vlax-safearray->list maxpt))
   
9.   (setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2));;求两点中点
   
10.   (setq mj (rtos (vla-get-area e_obj) 2 3))
    
11.   (entmake
    
12.     (list '(0 . "TEXT")
    
13.           (cons 1 mj)
    
14.           (cons 10 mid)
    
15.           (cons 40 (* (vla-get-area e_obj) 0.0001))
    
16.     )
    
17.   )
    
18.   (setq wjb (cdr (assoc 5 (entget (entlast)))))
    
19.   (setq wjl (list wjb))
    
20.   (setq objlt (list e_obj))        ;图元名转换为VLA对象
    
21.   (setq        vrl (vlr-pers
    
22.               (vlr-object-reactor objlt wjl '((:vlr-modified . c-2l)))
    
23.             )
    
24.   )
    
25.   (princ)                                ;静默退出
    
26. )
    
27. (defun c-2l (notifier-object
    
28.              reactor-object
    
29.              parameter-list
    
30.              /
    
31.             )
    
32.   (setq mj (rtos (vla-get-area notifier-object) 2 3))
    
33.   (vla-getboundingbox notifier-object 'minpt 'maxpt)
    
34.   (setq p1 (vlax-safearray->list minpt))
    
35.   (setq p2 (vlax-safearray->list maxpt))
    
36.   (setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2)) ;;求两点中点
    
37.   (setq we (handent (car (vlr-data reactor-object)))) ;获取文本图元名
    
38.   (setq wel (entget we))
    
39.   (setq wel (subst (vl-list* 10 mid) (assoc 10 wel) wel))
    
40.   (setq wel (subst (vl-list* 1 mj) (assoc 1 wel) wel))
    
41.   (setq
    
42.     wel        (subst (vl-list* 40 (* (vla-get-area notifier-object) 0.0001))
    
43.                (assoc 40 wel)
    
44.                wel
    
45.         )
    
46.   )
    
47.   (entmod wel)                                ;更新文本图元表
    
48. )
    
49. ；；；；；；；；
    
50. ;changyiran版主高见，怪不得为啥我有时候第一次运行程序时会出错，第二次就恢复正常了，估计就是ucs和wcs不一致造成的，另外fjdb和wzgx是我编的函数，一个是求拐点坐标，一个是判断点在多边形内外，感觉比较简单就没放上去
    
51. (defun wzgx(pt e / p e1 area area1 dist dist1)
    
52.    (setq e(vlax-ename->vla-object e)dist(distance(reverse(cdr(reverse pt)))(vlax-curve-getclosestpointto e pt))area(vla-get-area e)
    
53.    e1(car(vlax-safearray->list(vlax-variant-value(vla-offset e(* dist 1e-4)))))area1(vla-get-area e1)
    
54.    dist1(distance(reverse(cdr(reverse pt)))(vlax-curve-getclosestpointto e1 pt)))  (entdel(entlast))
    
55.    (if(< dist 1e-6)0;;线上
    
56.      (if(>(*(- area1 area)(- dist1 dist))0)1 -1)));1线内-1线外
    
57. ;[功能] pline,lwpline点坐标表  By 无痕;;示例(vxs (car (entsel))),返回三维点坐标
    
58. (defun fjdb (e / i v lst)
    
59.   (setq i 0)
    
60.   (while
    
61.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
    
62.      (setq lst (cons v lst))
    
63.   )
    
64.   (reverse lst))
    
65. ;;;;;;;;;;;;;;;
    
66. 
    
67. 
    
68. 
    
69. (defun c:dtmj(/ );动态面积
    
70.   (command"undo""m")
    
71.   (if(and(setq en(car(setq xz(entsel"\n请选择地块线："))))
    
72.          (="0"(cdr(assoc 8(setq el(entget en)))))
    
73.      )
    
74.     (progn
    
75.       (setq bb(fjdb en)
    
76.             obj(vlax-ename->vla-object en)
    
77.             mjss(ssget'"cp"bb'((0 . "text")(8 . "0")))
    
78.             n -1
    
79.       )
    
80.       (repeat(sslength mjss)
    
81.           (setq men(ssname mjss(setq n(1+ n))))
    
82.           (setq zdzd(cdr(assoc 11(entget men))))
    
83.           (if(=(wzgx zdzd en)1)
    
84.             (setq mjen men)
    
85.           )
    
86.       )
    
87.       (setq
    
88.             pt(cadr xz)
    
89.             zjd(vlax-curve-getclosestpointto obj pt)
    
90.             cs(vlax-curve-getParamAtPoint obj zjd)
    
91.             cs(atoi(rtos cs 2 0))
    
92.             pt(vlax-curve-getpointatparam obj cs)
    
93.             pt(list(car pt)(cadr pt))
    
94.             mode t
    
95.       )
    
96.       (while mode
    
97.              (setq mo(grread t 15 0)
    
98.                    co(car mo)
    
99.              )
    
100.              (cond((member co '(2 3 25 32))        ;其它 右键 右键 空格
     
101.                    (setq mode nil)
     
102.                   )
     
103.                   (t
     
104.                    (setq p1(cadr mo))
     
105.                    (entmod(subst(cons 10 p1)(cons 10 pt)el))
     
106.                    (setq bb(fjdb en))
     
107.                    (setq zxzb(list(/(apply'+(mapcar'(lambda(x)(car x))bb))(length bb))(/(apply'+(mapcar'(lambda(x)(cadr x))bb))(length bb))))
     
108.                    (setq mj(rtos(*(vla-get-area obj) 1) 2 3))
     
109.                    (setq mjel(subst(cons 1 mj)(assoc 1(entget mjen))(entget mjen)))
     
110.                    (entmod(subst(cons 11 zxzb)(assoc 11 mjel)mjel))
     
111.                   )
     
112.              )
     
113.       )
     
114.      )
     
115.    )
     
116. )

(vl-load-com)<br /> (defun c:c1 (/)<br />   (setq e (car (entsel "\n 请选择多边形==>>  ")))<br />   (setq e_obj (vlax-ename->vla-object e))<br />   (vla-getboundingbox e_obj 'minpt 'maxpt)<br />   (setq p1 (vlax-safearray->list minpt))<br />   (setq p2 (vlax-safearray->list maxpt))<br />   (setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2));;求两点中点<br />   (setq mj (rtos (vla-get-area e_obj) 2 3))<br />   (entmake<br />     (list '(0 . "TEXT")<br />           (cons 1 mj)<br />           (cons 10 mid)<br />           (cons 40 (* (vla-get-area e_obj) 0.0001))<br />     )<br />   )<br />   (setq wjb (cdr (assoc 5 (entget (entlast)))))<br />   (setq wjl (list wjb))<br />   (setq objlt (list e_obj))        ;图元名转换为VLA对象<br />   (setq        vrl (vlr-pers<br />               (vlr-object-reactor objlt wjl '((:vlr-modified . c-2l)))<br />             )<br />   )<br />   (princ)                                ;静默退出<br /> )<br /> (defun c-2l (notifier-object<br />              reactor-object<br />              parameter-list<br />              /<br />             )<br />   (setq mj (rtos (vla-get-area notifier-object) 2 3))<br />   (vla-getboundingbox notifier-object 'minpt 'maxpt)<br />   (setq p1 (vlax-safearray->list minpt))<br />   (setq p2 (vlax-safearray->list maxpt))<br />   (setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2)) ;;求两点中点<br />   (setq we (handent (car (vlr-data reactor-object)))) ;获取文本图元名<br />   (setq wel (entget we))<br />   (setq wel (subst (vl-list* 10 mid) (assoc 10 wel) wel))<br />   (setq wel (subst (vl-list* 1 mj) (assoc 1 wel) wel))<br />   (setq<br />     wel        (subst (vl-list* 40 (* (vla-get-area notifier-object) 0.0001))<br />                (assoc 40 wel)<br />                wel<br />         )<br />   )<br />   (entmod wel)                                ;更新文本图元表<br /> )<br /> ；；；；；；；；<br /> ;changyiran版主高见，怪不得为啥我有时候第一次运行程序时会出错，第二次就恢复正常了，估计就是ucs和wcs不一致造成的，另外fjdb和wzgx是我编的函数，一个是求拐点坐标，一个是判断点在多边形内外，感觉比较简单就没放上去<br /> (defun wzgx(pt e / p e1 area area1 dist dist1)<br />    (setq e(vlax-ename->vla-object e)dist(distance(reverse(cdr(reverse pt)))(vlax-curve-getclosestpointto e pt))area(vla-get-area e)<br />    e1(car(vlax-safearray->list(vlax-variant-value(vla-offset e(* dist 1e-4)))))area1(vla-get-area e1)<br />    dist1(distance(reverse(cdr(reverse pt)))(vlax-curve-getclosestpointto e1 pt)))  (entdel(entlast))<br />    (if(< dist 1e-6)0;;线上<br />      (if(>(*(- area1 area)(- dist1 dist))0)1 -1)));1线内-1线外<br /> ;[功能] pline,lwpline点坐标表  By 无痕;;示例(vxs (car (entsel))),返回三维点坐标<br /> (defun fjdb (e / i v lst)<br />   (setq i 0)<br />   (while<br />     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />      (setq lst (cons v lst))<br />   )<br />   (reverse lst))<br /> ;;;;;;;;;;;;;;;<br /> <br /> <br /> <br /> (defun c:dtmj(/ );动态面积<br />   (command"undo""m")<br />   (if(and(setq en(car(setq xz(entsel"\n请选择地块线："))))<br />          (="0"(cdr(assoc 8(setq el(entget en)))))<br />      )<br />     (progn<br />       (setq bb(fjdb en)<br />             obj(vlax-ename->vla-object en)<br />             mjss(ssget'"cp"bb'((0 . "text")(8 . "0")))<br />             n -1<br />       )<br />       (repeat(sslength mjss)<br />           (setq men(ssname mjss(setq n(1+ n))))<br />           (setq zdzd(cdr(assoc 11(entget men))))<br />           (if(=(wzgx zdzd en)1)<br />             (setq mjen men)<br />           )<br />       )<br />       (setq <br />             pt(cadr xz)<br />             zjd(vlax-curve-getclosestpointto obj pt)<br />             cs(vlax-curve-getParamAtPoint obj zjd)<br />             cs(atoi(rtos cs 2 0))<br />             pt(vlax-curve-getpointatparam obj cs)<br />             pt(list(car pt)(cadr pt))<br />             mode t<br />       )<br />       (while mode<br />              (setq mo(grread t 15 0)<br />                    co(car mo)<br />              )<br />              (cond((member co '(2 3 25 32))        ;其它 右键 右键 空格<br />                    (setq mode nil)<br />                   )<br />                   (t<br />                    (setq p1(cadr mo))<br />                    (entmod(subst(cons 10 p1)(cons 10 pt)el))<br />                    (setq bb(fjdb en))<br />                    (setq zxzb(list(/(apply'+(mapcar'(lambda(x)(car x))bb))(length bb))(/(apply'+(mapcar'(lambda(x)(cadr x))bb))(length bb))))<br />                    (setq mj(rtos(*(vla-get-area obj) 1) 2 3))<br />                    (setq mjel(subst(cons 1 mj)(assoc 1(entget mjen))(entget mjen)))<br />                    (entmod(subst(cons 11 zxzb)(assoc 11 mjel)mjel))<br />                   )<br />              )<br />       )<br />      )<br />    )<br /> )

小萝卜头changyiran的动态调整多段线面积（论坛里的）和newbuser的程序

sicky111

免费的非源码呢？

永不言弃

sicky111 发表于 2015-8-27 21:07
免费的非源码呢？

在五楼                  

sicky111

永不言弃 发表于 2015-8-28 14:39
在五楼

五楼是收费的源码，我想要免费的非源码，能用就好了，呵呵。

yangchao2005090

香田里浪人 发表于 2015-8-22 17:37
作者已经设置标注字体在mj层，字体高度为2，另外作者标注面积单位是“亩”，如果要换算为“平方米”可把
...

请问一下这个字体高度怎么改啊

LIULISHENG

有源我来顶一下