文本标注封闭多段线的边长和面积

ht1480

首先感谢前辈们的函数。这个是用前辈的函数东拼西凑起来的功能。

还需要完善，角度相同的两段边长可以合并标注，两节点重合的多余节点删除，异形的图形面积不在圈内等等。
小白一个，凑个贴子数

2. (vl-load-com)
   
3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;函数部分
   
4. (setq *ACAD*  (vlax-get-acad-object)
   
5.       *DOC*   (vla-get-ActiveDocument *ACAD*)
   
6.       *DOCS*  (vla-get-Documents *ACAD*)
   
7.       *MS*    (vla-get-modelSpace *DOC*))
   
8. (defun C:bbc( / osmbak all pianyiliang zigao i ent obj1 lst n m p1 p2 an ds zxd bpt js)
   
9. (setvar "dimzin" 0)
   
10. (setq osmbak(getvar "osmode"))
    
11. (setvar "osmode" 0 )
    
12. (setq all (ssget '((0 . "LWPOLYLINE,POLYLINE"))));;获取多线段图元
    
13. (setq pianyiliang 0.30);;设置偏移量
    
14. (setq zigao 0.5);;;设置字高
    
15. (LayerExist "bc");;;创建bc图层
    
16. (setq i 0)
    
17. (repeat (sslength all)
    
18.   (setq ent (ssname all i));;取得图元名
    
19.    (setq obj1 (vlax-ename->vla-object ent));;;多线段的对象属性
    
20.                   (entmake
    
21.                   (list '(0 . "TEXT")
    
22.                   (cons 1 (rtos (vla-get-area obj1) 2 2));;;(vla-get-area obj)提取到面积属性
    
23.                   (cons 10 (GetCentroid ent));;;(GetCentroid ent)质心点坐标，未采用几何中心
    
24.                   (cons 40 (* zigao 1.3))
    
25.                   (cons 11 (GetCentroid ent))
    
26.                   (cons 72 1)
    
27.                   (cons 73 2)
    
28.                   (cons 7 "宋体")
    
29.                   (cons 8 "bc")
    
30.                   ;(cons 50 an)   
    
31.                   ))
    
32.          (setq lst (mqb:getpt ent));;取得坐标点表
    
33.    (setq n 0)
    
34.    (setq m(length lst))
    
35.     (repeat m
    
36. ;;;;(nth(rem(+ i(setq m(length lst)))m)lst)取列表第i个元素,主要用在首尾衔接
    
37.        (setq p1 (nth(rem(+ n m)m)lst))
    
38.        (setq n(+ 1 n))
    
39.        (setq p2 (nth(rem(+ n m)m)lst))
    
40.        (setq an (angle p1 p2))
    
41.        (setq ds (distance p1 p2))
    
42.        (setq zxd (polar p1 an (* ds 0.5)))
    
43.        (if (and (> an 1.62316)(< an 4.76475))
    
44.            (setq an(+ an pi))
    
45.        )
    
46.       (setq bpt(polar zxd (+ an 1.5708) pianyiliang))      
    
47.        (if (PtInPts lst bpt)
    
48.          (entmake
    
49.                   (list '(0 . "TEXT")
    
50.                   (cons 1 (rtos ds 2 2))
    
51.                   (cons 10 bpt)
    
52.                   (cons 40 zigao)
    
53.                   (cons 11 bpt)
    
54.                   (cons 72 1)
    
55.                   (cons 73 2)
    
56.                   (cons 7 "宋体")
    
57.                   (cons 8 "bc")
    
58.                   (cons 50 an)   
    
59.                  ))
    
60.          (progn
    
61.           (setq bpt(polar zxd (- an 1.5708) pianyiliang))
    
62.             (entmake
    
63.                   (list '(0 . "TEXT")
    
64.                   (cons 1 (rtos ds 2 2))
    
65.                   (cons 10 bpt)
    
66.                   (cons 40 zigao)
    
67.                   (cons 11 bpt)
    
68.                   (cons 72 1)
    
69.                   (cons 73 2)
    
70.                   (cons 7 "宋体")
    
71.                   (cons 8 "bc")
    
72.                   (cons 50 an)   
    
73.                  ))
    
74.          ))
    
75.       (setq js (append js (list an ds)))
    
76.     )
    
77.   (setq i(+ 1 i))
    
78. )
    
79. ;(setq js nil)
    
80. ;( * 0.5 pi)
    
81. ;(angtof "273")
    
82. ;(angtos 2.3)
    
83. (setvar "osmode" osmbak)
    
84. )
    
85. 
    
86. ;;146 [功能] 质心
    
87. ;;示例 (GetCentroid (car(entsel)))
    
88. (defun GetCentroid (poly / AXERR CEN PL REG VA)
    
89.    (setq pl  (vlax-ename->vla-object poly);;(setq pl (*En2Obj* poly)
    
90.         va (vlax-make-safearray vlax-vbObject '(0 . 0))
    
91.   )
    
92.   (vlax-safearray-put-element va 0 pl)
    
93.   (setq axErr (VL-CATCH-ALL-APPLY 'vla-addregion (list *MS* va)))
    
94.   (if (VL-CATCH-ALL-ERROR-P axErr)
    
95.     nil
    
96.     (progn
    
97.       (setq reg (car (vlax-safearray->list (vlax-variant-value axErr)))
    
98.             cen (vla-get-centroid reg)
    
99.       )
    
100.       (vla-delete reg)
     
101.       (vlax-safearray->list (vlax-variant-value cen))
     
102.     )
     
103.   )
     
104. )  
     
105. 
     
106. ;;获取坐标函数  图元名
     
107. (defun mqb:getpt(getptss / ptlst)
     
108. (setq ptlst (vl-remove-if 'not (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) (entget getptss))))
     
109. )
     
110. ;; 判断图层是否存在(不存在则创建);;(LayerExist "dim")
     
111. (defun LayerExist (LayerName)
     
112.   (if (tblobjname "LAYER" LayerName) ;(tblsearch "LAYER" "3")也可判断图层3是否存在
     
113.     nil
     
114.     (entmake (list
     
115.         '(0 . "LAYER")
     
116.         '(100 . "AcDbSymbolTableRecord")
     
117.         '(100 . "AcDbLayerTableRecord")
     
118.      ;'(6 . "CONTINUOUS") ;线型
     
119.      ;'(62 . 3)   ;颜色
     
120.         '(70 . 0)  ;图层状态
     
121.         (cons 2 LayerName) ;图层名
     
122.       )
     
123.     )
     
124.   )
     
125. )
     
126. ;;以文字中心位置输出函数
     
127. (defun mqb:EntmakeText (PT STR Textheigh);以文字中心位置输出函数
     
128.   (entmake
     
129.     (list '(0 . "TEXT")
     
130.    (cons 1 str)
     
131.    (cons 10 pt)
     
132.    (cons 40 Textheigh)
     
133.    (cons 11 pt)
     
134.    (cons 72 1)
     
135.    (cons 73 2)
     
136.    (cons 7 "宋体")   
     
137.     )
     
138.   )
     
139. )
     
140. ;;[功能] pt是否在点集包围范围内
     
141. (defun PtInPts (pts pt / P1 P2)
     
142.   (setq
     
143.     pts (MAPCAR
     
144.    '(LAMBDA (p1 p2) (REM (- (ANGLE pt p1) (ANGLE pt p2)) PI))
     
145.    (CONS (LAST pts) pts)
     
146.    pts
     
147. )
     
148.   )
     
149.   (equal (ABS (APPLY '+ pts)) PI 1e-8)
     
150. )
     
151. ;生成文字样式
     
152. (defun mqb:create-st (/ textstyles textstyle)
     
153.   (setq textstyles (vla-get-textstyles *DOC*))
     
154.   ;(setq textstyle1 (vla-add textstyles "方正中等线_GBK"))
     
155.   ;(setq textstyle2 (vla-add textstyles "方正细等线简体"))
     
156.   ;(setq textstyle3 (vla-add textstyles "方正中等线简体"))
     
157.   (setq textstyle4 (vla-add textstyles "宋体"))
     
158.   ;(vla-setfont textstyle1 "方正中等线_GBK" :vlax-false :vlax-false 1 0)
     
159.   ;(vla-setfont textstyle2 "方正细等线简体" :vlax-false :vlax-false 1 0)
     
160.   ;(vla-setfont textstyle3 "方正中等线简体" :vlax-false :vlax-false 1 0)
     
161.   (vla-setfont textstyle4 "宋体" :vlax-false :vlax-false 1 0)
     
162.   (setvar "cmdecho" 0)
     
163.   (vl-cmdf "_.style" "" "" "" "1.0" "" "" "" "")
     
164.   (princ)
     
165.   )
     
166. (mqb:create-st)
     
167. 
     
168. 
     
169. (DEFUN C:6(/ osmbak txth p1 p2 p3 d1 a1 a2 p4 p5) ;单线标注
     
170. (command "layer" "m" "0" "")
     
171.                     (setq osmbak(getvar "osmode"))
     
172.                     (setvar "osmode" 1 )
     
173.                     ;(setq txth (getreal "输入注记字高："))
     
174.                     (setq p1 ( getpoint "\n      点一下起点: "))
     
175.                     (setq p2 ( getpoint p1 "\n       点一下终止点: "))
     
176.                     (setvar "osmode" 0)
     
177.                     (setq p3 ( getpoint p2 "\n     点取标注点:"))
     
178.                     (setq d1 ( distance p1 p2 ))
     
179. (setq txth(+ 0.25 (* d1 0.003)))
     
180.                     (setq a1 ( angle p2 p1 ))
     
181.                     (setq a2 ( angle p2 p3 ))
     
182.                     (setq p4 ( polar p1 (- a1 pi ) (/ d1 2 )))
     
183.                     (if ( <= a2 a1 )
     
184.                         ( setq p5 ( polar p4 ( - a1 (/ pi 2)) (+ 0.05 (* txth 0.5))))
     
185.                            )
     
186.                     (if ( >= a2 a1 )
     
187.                         ( setq p5 ( polar p4 ( + a1 (/ pi 2)) (+ 0.05 (* txth 0.5))))
     
188.                              )
     
189.   (LayerExist "bc")
     
190. (entmake
     
191.     (list '(0 . "TEXT")
     
192.    (cons 1 (rtos d1 2 2))
     
193.    (cons 10 p5)
     
194.    (cons 40 txth)
     
195.    (cons 11 p5)
     
196.    (cons 72 1)
     
197.    (cons 73 2)
     
198.    (cons 7 "宋体")
     
199.    (cons 8 "bc")
     
200.    (cons 50 (- a1 pi))   
     
201.     ))
     
202.                     (setvar "osmode" osmbak)
     
203.                     (princ)
     
204.                     )

(vl-load-com)<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;函数部分<br /> (setq *ACAD*  (vlax-get-acad-object)<br />       *DOC*   (vla-get-ActiveDocument *ACAD*)<br />       *DOCS*  (vla-get-Documents *ACAD*)<br />       *MS*    (vla-get-modelSpace *DOC*))<br /> (defun C:bbc( / osmbak all pianyiliang zigao i ent obj1 lst n m p1 p2 an ds zxd bpt js)<br /> (setvar "dimzin" 0)<br /> (setq osmbak(getvar "osmode"))<br /> (setvar "osmode" 0 )<br /> (setq all (ssget '((0 . "LWPOLYLINE,POLYLINE"))));;获取多线段图元<br /> (setq pianyiliang 0.30);;设置偏移量<br /> (setq zigao 0.5);;;设置字高<br /> (LayerExist "bc");;;创建bc图层<br /> (setq i 0)<br /> (repeat (sslength all)<br />   (setq ent (ssname all i));;取得图元名<br />    (setq obj1 (vlax-ename->vla-object ent));;;多线段的对象属性<br />                   (entmake<br />                   (list '(0 . "TEXT")<br />                   (cons 1 (rtos (vla-get-area obj1) 2 2));;;(vla-get-area obj)提取到面积属性<br />                   (cons 10 (GetCentroid ent));;;(GetCentroid ent)质心点坐标，未采用几何中心<br />                   (cons 40 (* zigao 1.3))<br />                   (cons 11 (GetCentroid ent))<br />                   (cons 72 1)<br />                   (cons 73 2)<br />                   (cons 7 "宋体")<br />                   (cons 8 "bc")<br />                   ;(cons 50 an)    <br />                   ))<br />          (setq lst (mqb:getpt ent));;取得坐标点表<br />    (setq n 0)<br />    (setq m(length lst))<br />     (repeat m<br /> ;;;;(nth(rem(+ i(setq m(length lst)))m)lst)取列表第i个元素,主要用在首尾衔接<br />        (setq p1 (nth(rem(+ n m)m)lst))<br />        (setq n(+ 1 n))<br />        (setq p2 (nth(rem(+ n m)m)lst))<br />        (setq an (angle p1 p2))<br />        (setq ds (distance p1 p2))<br />        (setq zxd (polar p1 an (* ds 0.5)))<br />        (if (and (> an 1.62316)(< an 4.76475))<br />            (setq an(+ an pi))<br />        )<br />       (setq bpt(polar zxd (+ an 1.5708) pianyiliang))      <br />        (if (PtInPts lst bpt)<br />          (entmake<br />                   (list '(0 . "TEXT")<br />                   (cons 1 (rtos ds 2 2))<br />                   (cons 10 bpt)<br />                   (cons 40 zigao)<br />                   (cons 11 bpt)<br />                   (cons 72 1)<br />                   (cons 73 2)<br />                   (cons 7 "宋体")<br />                   (cons 8 "bc")<br />                   (cons 50 an)    <br />                  ))<br />          (progn<br />           (setq bpt(polar zxd (- an 1.5708) pianyiliang))<br />             (entmake<br />                   (list '(0 . "TEXT")<br />                   (cons 1 (rtos ds 2 2))<br />                   (cons 10 bpt)<br />                   (cons 40 zigao)<br />                   (cons 11 bpt)<br />                   (cons 72 1)<br />                   (cons 73 2)<br />                   (cons 7 "宋体")<br />                   (cons 8 "bc")<br />                   (cons 50 an)    <br />                  ))<br />          ))<br />       (setq js (append js (list an ds)))<br />     )<br />   (setq i(+ 1 i))<br /> )<br /> ;(setq js nil)<br /> ;( * 0.5 pi)<br /> ;(angtof "273") <br /> ;(angtos 2.3)<br /> (setvar "osmode" osmbak)<br /> )<br /> <br /> ;;146 [功能] 质心<br /> ;;示例 (GetCentroid (car(entsel)))<br /> (defun GetCentroid (poly / AXERR CEN PL REG VA)<br />    (setq pl  (vlax-ename->vla-object poly);;(setq pl (*En2Obj* poly)<br />         va (vlax-make-safearray vlax-vbObject '(0 . 0))<br />   )<br />   (vlax-safearray-put-element va 0 pl)<br />   (setq axErr (VL-CATCH-ALL-APPLY 'vla-addregion (list *MS* va)))<br />   (if (VL-CATCH-ALL-ERROR-P axErr)<br />     nil<br />     (progn<br />       (setq reg (car (vlax-safearray->list (vlax-variant-value axErr)))<br />             cen (vla-get-centroid reg)<br />       )<br />       (vla-delete reg)<br />       (vlax-safearray->list (vlax-variant-value cen))<br />     )<br />   )<br /> )  <br /> <br /> ;;获取坐标函数  图元名<br /> (defun mqb:getpt(getptss / ptlst)<br /> (setq ptlst (vl-remove-if 'not (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) (entget getptss))))<br /> )<br /> ;; 判断图层是否存在(不存在则创建);;(LayerExist "dim")<br /> (defun LayerExist (LayerName)<br />   (if (tblobjname "LAYER" LayerName) ;(tblsearch "LAYER" "3")也可判断图层3是否存在<br />     nil<br />     (entmake (list<br />         '(0 . "LAYER")<br />         '(100 . "AcDbSymbolTableRecord")<br />         '(100 . "AcDbLayerTableRecord")<br />      ;'(6 . "CONTINUOUS") ;线型<br />      ;'(62 . 3)   ;颜色<br />         '(70 . 0)  ;图层状态<br />         (cons 2 LayerName) ;图层名<br />       )<br />     )<br />   )<br /> )<br /> ;;以文字中心位置输出函数<br /> (defun mqb:EntmakeText (PT STR Textheigh);以文字中心位置输出函数<br />   (entmake<br />     (list '(0 . "TEXT")<br />    (cons 1 str)<br />    (cons 10 pt)<br />    (cons 40 Textheigh)<br />    (cons 11 pt)<br />    (cons 72 1)<br />    (cons 73 2)<br />    (cons 7 "宋体")    <br />     )<br />   )<br /> )<br /> ;;[功能] pt是否在点集包围范围内<br /> (defun PtInPts (pts pt / P1 P2)<br />   (setq<br />     pts (MAPCAR<br />    '(LAMBDA (p1 p2) (REM (- (ANGLE pt p1) (ANGLE pt p2)) PI))<br />    (CONS (LAST pts) pts)<br />    pts<br /> )<br />   )<br />   (equal (ABS (APPLY '+ pts)) PI 1e-8)<br /> )<br /> ;生成文字样式<br /> (defun mqb:create-st (/ textstyles textstyle)<br />   (setq textstyles (vla-get-textstyles *DOC*))<br />   ;(setq textstyle1 (vla-add textstyles "方正中等线_GBK"))<br />   ;(setq textstyle2 (vla-add textstyles "方正细等线简体"))<br />   ;(setq textstyle3 (vla-add textstyles "方正中等线简体"))<br />   (setq textstyle4 (vla-add textstyles "宋体"))<br />   ;(vla-setfont textstyle1 "方正中等线_GBK" :vlax-false :vlax-false 1 0)<br />   ;(vla-setfont textstyle2 "方正细等线简体" :vlax-false :vlax-false 1 0)<br />   ;(vla-setfont textstyle3 "方正中等线简体" :vlax-false :vlax-false 1 0)<br />   (vla-setfont textstyle4 "宋体" :vlax-false :vlax-false 1 0)<br />   (setvar "cmdecho" 0)<br />   (vl-cmdf "_.style" "" "" "" "1.0" "" "" "" "")<br />   (princ)<br />   )<br /> (mqb:create-st)<br /> <br /> <br /> (DEFUN C:6(/ osmbak txth p1 p2 p3 d1 a1 a2 p4 p5) ;单线标注<br /> (command "layer" "m" "0" "")<br />                     (setq osmbak(getvar "osmode"))<br />                     (setvar "osmode" 1 )<br />                     ;(setq txth (getreal "输入注记字高："))<br />                     (setq p1 ( getpoint "\n      点一下起点: "))<br />                     (setq p2 ( getpoint p1 "\n       点一下终止点: "))<br />                     (setvar "osmode" 0)<br />                     (setq p3 ( getpoint p2 "\n     点取标注点:"))<br />                     (setq d1 ( distance p1 p2 ))<br /> (setq txth(+ 0.25 (* d1 0.003)))<br />                     (setq a1 ( angle p2 p1 ))<br />                     (setq a2 ( angle p2 p3 ))<br />                     (setq p4 ( polar p1 (- a1 pi ) (/ d1 2 )))<br />                     (if ( <= a2 a1 )<br />                         ( setq p5 ( polar p4 ( - a1 (/ pi 2)) (+ 0.05 (* txth 0.5)))) <br />                            )<br />                     (if ( >= a2 a1 )<br />                         ( setq p5 ( polar p4 ( + a1 (/ pi 2)) (+ 0.05 (* txth 0.5))))<br />                              )<br />   (LayerExist "bc")<br /> (entmake<br />     (list '(0 . "TEXT")<br />    (cons 1 (rtos d1 2 2))<br />    (cons 10 p5)<br />    (cons 40 txth)<br />    (cons 11 p5)<br />    (cons 72 1)<br />    (cons 73 2)<br />    (cons 7 "宋体")<br />    (cons 8 "bc")<br />    (cons 50 (- a1 pi))    <br />     ))<br />                     (setvar "osmode" osmbak)<br />                     (princ)<br />                     )

ht1480

kfh 发表于 2023-2-15 22:09
字体高度怎么设置？

我自己用的小工具，不需要改字高所以没有加设置的功能，你不经常改字高的话可以把
(setq pianyiliang 0.30);;设置偏移量
(setq zigao 0.5);;;设置字高，这两行代码删掉
不经常改字高的话就写
(if (= shezhizg nil) (setq zigao 0.5)(setq zigao shezhizg))
(setq pianyiliang (* zigao 0.6))
想改字高时就在命令行里输入(setq shezhizg *字高的数字值*)
改的特别频繁的话你就改成
(setq zigao (getreal "请输入字高："))
(setq pianyiliang (* zigao 0.6))
这样每次标注前会提示输入字高

ht1480

BHL-DONG 发表于 2023-2-17 09:25
不知道为啥，我是按ctrl+a复制的，加载进去就显示语法错误，不过楼主你发的就没有问题

复制代码时我也遇到过，最常见的有两点
1、复制选择时，代码最末尾的括号给漏掉了。
2、粘贴到编辑器里时有时是中文输入状态，括号那些符号是中文的符号，代码就报错。

ht1480

效果图看不到

magicheno

感谢大佬分享~

kfh

字体高度怎么设置？

BHL-DONG

加载进cad显示语法错误

ht1480

BHL-DONG 发表于 2023-2-16 09:41
加载进cad显示语法错误

也许是你没有复制完整吧

hzyhzjjzh

感谢大佬分享~

BHL-DONG

ht1480 发表于 2023-2-16 11:38
也许是你没有复制完整吧

不知道为啥，我是按ctrl+a复制的，加载进去就显示语法错误，不过楼主你发的就没有问题