搬运一个外网的代码：标注动态显示多段线的长度和面积
本帖最后由 yanshengjiang 于 2025-9-9 16:44 编辑第一次见到这种写法，所以搬运过来。多边形变化后 ，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)
[*]
edata 发表于 2025-9-9 14:30
测试
粘贴掉几个字符
测试
(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 发表于 2025-9-9 16:45
粘贴掉几个字符
经你这么对比
总算明白了
有些从论坛上复制下来的代码
总是出错
达不到发码人说的效果
可能就是这个原因了
谢谢你的对比提示
不知论坛对这种情况能不能改进一下？ ynhh 发表于 2025-9-10 00:01
经你这么对比
总算明白了
有些从论坛上复制下来的代码
发帖内含有代码最好是用专门的代码模块
代码模块 这代码能运行？ guosheyang 发表于 2025-9-9 12:32
这代码能运行？
我复制下来居然也报错。奇怪。 guosheyang 发表于 2025-9-9 12:32
这代码能运行？
应该是论坛粘贴复制出问题了。 %lu2%pr2 前后再加上个 "似乎可以 应该用的面积周长的字段表达式
能运行，但是选取对象然后拉引线时报错：
https://i.imgs.ovh/2025/09/09/77s5G1.jpeg guosheyang 发表于 2025-9-9 13:12
应该用的面积周长的字段表达式
应该是，但以前从没见过这个大家都用反应器。
页:
[1]
2