搬运一个外网的代码：标注动态显示多段线的长度和面积

yanshengjiang

第一次见到这种写法，所以搬运过来。  多边形变化后 ，regen可以更新注记。
这代码复制粘贴出去多半要报错，附上lsp文件。
https://www.cadtutor.net/forum/topic/19063-object
(defun C:FA  (/ acsp adoc cpt elist en ent fld lead_obj lpt mtx oid osm)
(vl-load-com)
(or adoc
     (setq adoc
     (vla-get-activedocument
       (vlax-get-acad-object)
       )
    )
     )
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
   (setq acsp (vla-get-paperspace adoc))
   (setq acsp (vla-get-modelspace adoc))
   )
(setq osm (getvar "osmode"))
(setvar "osmode" 0)

(while
   (setq ent (entsel "\nSelect pline or hit Enter to exit"))
    (setq en (car ent))
    (if (wcmatch (cdr (assoc 0 (setq elist (entget en)))) "*POLYLINE")
      (progn
(setq cpt (trans (cadr ent)1 0)
       lpt (trans (getpoint cpt "\nPick the ending point of leader:") 1 0)
       )

(setq oID (vla-get-objectid (vlax-ename->vla-object en)))
(setq fld
    (strcat
      (strcat "Area = " "%<\\AcObjProp Object(%<\\_ObjId "
          (itoa oID)
          ">%).Area \\f \"%lu2%pr2\">%"
          "\\P")
      (strcat "Perimeter = " "%<\\AcObjProp Object(%<\\_ObjId "
          (itoa oID)
          ">%).Length \\f \"%lu2%pr2\">%"))
       )
(setq mtx (vlax-invoke
         acsp 'AddMText lpt 0.0 fld)
       )
(vlax-put mtx
       'AttachmentPoint
       (cond ((> (car cpt) (car lpt))
          6
          )
         ((< (car cpt) (car lpt))
          4
          )
         (T 4)
         )
       )
(vlax-put mtx 'Height (getvar "textsize"))
(setq lead_obj    (vlax-invoke
          acsp
          'Addleader
          (apply 'append (list cpt lpt))
          mtx
          acLineWithArrow
          )
       )
(vlax-put lead_obj 'VerticalTextPosition 0);1
)
      )
    )
(setvar "osmode" osm)
(princ)
)
(princ "\n Start command with FA ...")
(princ)

• 
  

yanshengjiang

edata 发表于 2025-9-9 14:30
测试

粘贴掉几个字符

edata

测试

1. (defun C:FA  (/ acsp adoc cpt elist en ent fld lead_obj lpt mtx oid osm)
   
2. (vl-load-com)
   
3. (or adoc
   
4.      (setq adoc
   
5.      (vla-get-activedocument
   
6.        (vlax-get-acad-object)
   
7.        )
   
8.     )
   
9.      )
   
10. (if (and
    
11. (= (getvar "tilemode") 0)
    
12. (= (getvar "cvport") 1)
    
13. )
    
14.    (setq acsp (vla-get-paperspace adoc))
    
15.    (setq acsp (vla-get-modelspace adoc))
    
16.    )
    
17. (setq osm (getvar "osmode"))
    
18. (setvar "osmode" 0)
    
19. 
    
20. (while
    
21.    (setq ent (entsel "\nSelect pline or hit Enter to exit"))
    
22.     (setq en (car ent))
    
23.     (if (wcmatch (cdr (assoc 0 (setq elist (entget en)))) "*POLYLINE")
    
24.       (progn
    
25. (setq cpt (trans (cadr ent)1 0)
    
26.        lpt (trans (getpoint cpt "\nPick the ending point of leader:") 1 0)
    
27.        )
    
28. 
    
29. (setq oID (vla-get-objectid (vlax-ename->vla-object en)))
    
30. (setq fld
    
31.   (strcat
    
32.     (strcat "Area = " "%<\\AcObjProp Object(%<\\_ObjId "
    
33.       (itoa oID)
    
34.       ">%).Area \\f \"%lu2%pr2\">%"
    
35.       "\\P")
    
36.     (strcat "Perimeter = " "%<\\AcObjProp Object(%<\\_ObjId "
    
37.       (itoa oID)
    
38.       ">%).Length \\f \"%lu2%pr2\">%"))
    
39.        )
    
40. (setq mtx (vlax-invoke
    
41.        acsp 'AddMText lpt 0.0 fld)
    
42.        )
    
43. (vlax-put mtx
    
44.      'AttachmentPoint
    
45.      (cond ((> (car cpt) (car lpt))
    
46.       6
    
47.       )
    
48.      ((< (car cpt) (car lpt))
    
49.       4
    
50.       )
    
51.      (T 4)
    
52.      )
    
53.      )
    
54. (vlax-put mtx 'Height (getvar "textsize"))
    
55. (setq lead_obj  (vlax-invoke
    
56.       acsp
    
57.       'Addleader
    
58.       (apply 'append (list cpt lpt))
    
59.       mtx
    
60.       acLineWithArrow
    
61.       )
    
62.        )
    
63. (vlax-put lead_obj 'VerticalTextPosition 0);1
    
64. )
    
65.       )
    
66.     )
    
67. (setvar "osmode" osm)
    
68. (princ)
    
69. )
    
70. (princ "\n Start command with FA ...")
    
71. (princ)

(defun C:FA  (/ acsp adoc cpt elist en ent fld lead_obj lpt mtx oid osm)<br /> (vl-load-com)<br /> (or adoc<br />      (setq adoc<br />      (vla-get-activedocument<br />        (vlax-get-acad-object)<br />        )<br />     )<br />      )<br /> (if (and<br /> (= (getvar "tilemode") 0)<br /> (= (getvar "cvport") 1)<br /> )<br />    (setq acsp (vla-get-paperspace adoc))<br />    (setq acsp (vla-get-modelspace adoc))<br />    )<br /> (setq osm (getvar "osmode"))<br /> (setvar "osmode" 0)<br /> <br /> (while<br />    (setq ent (entsel "\nSelect pline or hit Enter to exit"))<br />     (setq en (car ent))<br />     (if (wcmatch (cdr (assoc 0 (setq elist (entget en)))) "*POLYLINE")<br />       (progn<br /> (setq cpt (trans (cadr ent)1 0)<br />        lpt (trans (getpoint cpt "\nPick the ending point of leader:") 1 0)<br />        )<br /> <br /> (setq oID (vla-get-objectid (vlax-ename->vla-object en)))<br /> (setq fld<br />   (strcat<br />     (strcat "Area = " "%<\\AcObjProp Object(%<\\_ObjId "<br />       (itoa oID)<br />       ">%).Area \\f \"%lu2%pr2\">%"<br />       "\\P")<br />     (strcat "Perimeter = " "%<\\AcObjProp Object(%<\\_ObjId "<br />       (itoa oID)<br />       ">%).Length \\f \"%lu2%pr2\">%"))<br />        )<br /> (setq mtx (vlax-invoke<br />        acsp 'AddMText lpt 0.0 fld)<br />        )<br /> (vlax-put mtx<br />      'AttachmentPoint<br />      (cond ((> (car cpt) (car lpt))<br />       6<br />       )<br />      ((< (car cpt) (car lpt))<br />       4<br />       )<br />      (T 4)<br />      )<br />      )<br /> (vlax-put mtx 'Height (getvar "textsize"))<br /> (setq lead_obj  (vlax-invoke<br />       acsp<br />       'Addleader<br />       (apply 'append (list cpt lpt))<br />       mtx<br />       acLineWithArrow<br />       )<br />        )<br /> (vlax-put lead_obj 'VerticalTextPosition 0);1<br /> )<br />       )<br />     )<br /> (setvar "osmode" osm)<br /> (princ)<br /> )<br /> (princ "\n Start command with FA ...")<br /> (princ)

ynhh

yanshengjiang 发表于 2025-9-9 16:45
粘贴掉几个字符

经你这么对比
总算明白了
有些从论坛上复制下来的代码
总是出错
达不到发码人说的效果
可能就是这个原因了
谢谢你的对比提示
不知论坛对这种情况能不能改进一下？

woshilj

ynhh 发表于 2025-9-10 00:01
经你这么对比
总算明白了
有些从论坛上复制下来的代码

发帖内含有代码最好是用专门的代码模块

1. 代码模块

复制代码

guosheyang

这代码能运行？

yanshengjiang

guosheyang 发表于 2025-9-9 12:32
这代码能运行？

我复制下来居然也报错。奇怪。

yanshengjiang

guosheyang 发表于 2025-9-9 12:32
这代码能运行？

应该是论坛粘贴复制出问题了。

guosheyang

%lu2%pr2   前后再加上个 "  似乎可以

guosheyang

应该用的面积  周长的字段表达式

guosheyang

npcer

能运行，但是选取对象然后拉引线时报错：

yanshengjiang

guosheyang 发表于 2025-9-9 13:12
应该用的面积  周长的字段表达式

应该是，但以前从没见过这个大家都用反应器。