【K:CreatRvTXT】创建云线文字标注

kucha007 · 发表于 2024-4-4 17:05

本帖最后由 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);刷新视图
)

;创建云线文字标注 
(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 "批注")

wangsr · 发表于 2024-4-4 19:26

谢谢分享。

szhorse · 发表于 2024-4-4 21:36

(K:CreatRvTXT (car (nentsel)) 230 1.0 "修改")

(K:CreatRvTXT (car (nentsel)) 230 1.0 "批注")

要这么长的命令吗😅

kucha007 · 发表于 2024-4-4 21:40

本帖最后由 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 "批注")

嘛，你有需要就自己改咯

cyfdean · 发表于 2024-4-6 08:36

谢谢分享

yefei812678 · 发表于 2024-4-7 08:09

感谢分享
感谢分享

moshouhot · 发表于 2024-4-30 15:10

(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)
)

账号		自动登录	找回密码
密码			注册

【K:CreatRvTXT】创建云线文字标注

本帖子中包含更多资源

评分