【K:CreatRvTXT】创建云线文字标注
本帖最后由 kucha007 于 2024-4-4 23:27 编辑之前写了云线标注，很多小伙伴反馈缺少文字标注。
刚好最近有小伙伴付费定制，就把原先的云线程序整体上做了一些修改。
主要是增加了这个子函数，也分享给大家耍耍~
;创建云线文字标注
(defun K:CreatRvTXT (TgtObj Col TgtDIM STR / CurCol Code StaPT EndPT MTEN)
(setq StaPT Nil EndPT Nil)
(if (eq 'ENAME (type TgtObj))(setq TgtObj (vlax-ename->vla-object TgtObj)))
(setq Col
(if (/= Col (atoi (setq CurCol (getvar "CECOLOR"))))
(cond
((= "BYBLOCK" CurCol) 7);随块
((= "BYLAYER" CurCol) (cdr (assoc 62 (tblsearch "layer" (getvar "CLAYER")))));随层
(T (atoi CurCol))
)
Col
)
)(redraw)
(while ;Grread
(progn
(princ "\n——★★★ 请指定标注点或空格 ★★★——\n")
(while (and (setq Code (grread T (+ 1 4 8) 0)) (eq (car Code) 5))
(redraw)
(setq StaPT (trans (cadr Code) 1 0) ;WCS
EndPT (vlax-curve-getClosestPointTo TgtObj StaPT);WCS
)
(grdraw (trans StaPT 0 1) (trans EndPT 0 1) Col);UCS
)
(cond
((and (eq (car Code) 3) (eq (type StaPT) 'LIST));点选
Nil ;退出循环
)
((equal Code '(2 32));空格
(redraw)
(setq StaPT (trans (cadr (grread '(2 32))) 1 0) ;WCS
EndPT (vlax-curve-getClosestPointTo TgtObj StaPT);WCS
)
(grdraw (trans StaPT 0 1) (trans EndPT 0 1) Col);UCS
Nil ;退出循环
)
(T
(princ "\n——★★★ 请输入点或 ESC退出！ ★★★——\n")
T ;继续循环
);退出循环
)
)
)
(if (and StaPT EndPT)
(progn
(entmake (list '(0 . "LINE") (cons 10 StaPT) (cons 11 EndPT)));直线
(setq MTEN
(entmakeX
(list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 10 StaPT)
(cons 40 (* TgtDIM 5.0));字高
(cons 41 (* TgtDIM 100.0));总页宽
(cons 71
(if (> (cadr (mapcar '- (trans StaPT 0 1)(trans EndPT 0 1))) 0);Y大,上侧
7 ;左下
1 ;左上
)
);对齐基点
(cons 1
(strcat
STR "时间："(menucmd "M=$(edtime,$(getvar,date),YYYY/MO/DD HH:MM)")
"\n" STR "人员："(getenv "USERNAME")
"\n" STR "内容："
)
);文字内容
(cons 50 (-
(- (* 2 pi) (getvar "viewtwist"))
(angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t) t)))
);文字旋转始终水平视图
)
);多行文字
)
(if MTEN
(progn
(command "_.MTEDIT" MTEN)
(while (> (getvar "CMDACTIVE") 0) (command PAUSE));等待前面的命令完成
)
);编辑多行文字
)
)
(redraw);刷新视图
)
用法：
(K:CreatRvTXT (car (nentsel)) 230 1.0 "修改")
(K:CreatRvTXT (car (nentsel)) 230 1.0 "批注")
谢谢分享。
(K:CreatRvTXT (car (nentsel)) 230 1.0 "修改")
(K:CreatRvTXT (car (nentsel)) 230 1.0 "批注")
要这么长的命令吗😅 本帖最后由 kucha007 于 2024-4-5 01:05 编辑
szhorse 发表于 2024-4-4 21:36
(K:CreatRvTXT (car (nentsel)) 230 1.0 "修改")
(K:CreatRvTXT (car (nentsel)) 230 1.0 "批注")
嘛，你有需要就自己改咯 谢谢分享:handshake
感谢分享
感谢分享 (defun-c TT (/ TgtObj Col TgtDIM STR)
(setq TgtObj (car (nentsel "\n选择一个对象: ")))
(setq Col 230) ; 颜色编号设置为230
(setq TgtDIM 1.0) ; 文字标注的高度设置为1.0
(setq STR "修改") ; 文字内容设置为"修改"
(K:CreatRvTXT TgtObj Col TgtDIM STR)
(princ)
)
本帖最后由 muai2010 于 2024-6-10 13:48 编辑
(K:CreatRvTXT (car (nentsel)) 230 1.0 "修改")除了修改生效，其他230 好像是不生效 谢谢分享:handshake 多谢分享，稍微调整了一点点，把文字高度跟全局比例关联了一下
页:
[1]