标注图层名在线段右侧
本帖最后由 nyistjz 于 2023-4-15 21:58 编辑给朋友做的一个小功能，希望能能更多人有用！
(defun c:tt(/ alist en h i pt ss str)
(setq ss (ssget '((0 . "*POLYLINE,LINE"))))
(setq i 0)
(repeat (sslength ss)
(setq en (ssname ss i) i (1+ i))
(setq alist (entget en))
(setq str (cdr (assoc 8 alist)))
(setq h 800)
(setq pt (vlax-curve-getendPoint (vlax-ename->vla-object en)))
(setq pt (mapcar '(lambda(x y)(+ x y)) pt (list (* 0.5 h) (* -0.3 h) 0)))
(entmake (list '(0 . "TEXT") (cons 1 str) (cons 8 str) (cons 10 pt) (cons 40 h) (cons 72 0)))
)
)
本帖最后由 kucha007 于 2023-4-15 23:51 编辑
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist输入。
03-命令编组方便撤回
(defun C:TT (/ DOC SS i en LayNam StaPt EndPt TgtPt Hight)
(vl-load-com)
(setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))
(vla-startundomark DOC)
(if (setq SS (ssget '((0 . "*POLYLINE,LINE"))))
(progn
(initget (+ 1 2 4)) ;非空非零非负值
(setq Hight (getdist "→请输入或量取文字高度："))
(repeat (setq i (sslength SS))
(setq en (ssname SS (setq i (1- i))))
(setq LayNam (cdr (assoc 8 (entget en))))
(setq StaPt (vlax-curve-getstartPoint (vlax-ename->vla-object en))) ; 起点坐标
(setq EndPt (vlax-curve-getendPoint (vlax-ename->vla-object en))) ; 终点坐标
(setq TgtPt (if (>= (car StaPt) (car EndPt)) StaPt EndPt))
(setq TgtPt (mapcar
'(lambda (x y) (+ x y))
TgtPt
(list (* 0.5 Hight) (* -0.3 Hight) 0)
)
)
(entmake
(list
'(0 . "TEXT")
(cons 1 LayNam) ;文字内容
(cons 8 LayNam) ;图层名称
(cons 10 TgtPt) ;插入点
(cons 40 Hight) ;文字高度
)
)
)
)
)
(vla-endundomark DOC)
(princ)
)
画线表示不理解，跟论坛中“提取图层名字”，是相同用法
;;提取图层名字
(defun C:tcn (/ LST N PT)
(setvar "cecolor" "bylayer")
(setq LST (reverse (TABLE "LAYER")))
(setq PT (getpoint "文字插入點: ")
N 0
)
(foreach NAME LST
(entmake (list '(0 . "TEXT") (cons 8 NAME) '(100 . "AcDbText") (cons 10
(list
(car PT)
(-
(cadr PT) N
)
)
) '
(40 . 6) (cons 1 NAME)
)
)
(setq N (+ N 10.0))
)
(princ)
)
(defun TABLE (S / D R)
(while (setq D (tblnext S (null D)))
(setq R (cons (cdr (assoc 2 D)) R))
)
) kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...
谢谢大佬分享实用功能 kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...
感谢大佬优化，输入命令选择对象后输入字高时出现乱码 kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...
你好，
首先，聊表谢意！谷雨快乐！
其次，附上GIF动图，直观，如有动图疑问，可查看下面链接教程；
Cad图块中线型比例修改 - AutoCAD工具插件 - AutoCAD论坛 - 明经CAD社区 - Powered by Discuz! (mjtd.com)
最后，能否将产生的文字放到公司标准的图层？
ferious 发表于 2023-4-20 16:39
你好，
首先，聊表谢意！谷雨快乐！
求个这个lisp，上面那个码复制了不行 本帖最后由 aggdqty 于 2023-4-20 22:56 编辑
kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...
试了一下，很实用，谢谢 wlpkok 发表于 2023-4-20 20:54
求个这个lisp，上面那个码复制了不行
(defun C:TTT4 (/ DOC SS i en LayNam StaPt EndPt TgtPt Hight)
(vl-load-com)
(setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))
(vla-startundomark DOC)
(if (setq SS (ssget '((0 . "*POLYLINE,LINE"))))
(progn
(initget (+ 1 2 4)) ;非空非零非负值
(setq Hight (getdist "→请输入或量取文字高度："))
(repeat (setq i (sslength SS))
(setq en (ssname SS (setq i (1- i))))
(setq LayNam (cdr (assoc 8 (entget en))))
(setq StaPt (vlax-curve-getstartPoint (vlax-ename->vla-object en))) ; 起点坐标
(setq EndPt (vlax-curve-getendPoint (vlax-ename->vla-object en))) ; 终点坐标
(setq TgtPt (if (>= (car StaPt) (car EndPt)) StaPt EndPt))
(setq TgtPt (mapcar
'(lambda (x y) (+ x y))
TgtPt
(list (* 0.5 Hight) (* -0.3 Hight) 0)
)
)
(entmake
(list
'(0 . "TEXT")
(cons 1 LayNam) ;文字内容
(cons 8 LayNam) ;图层名称
(cons 10 TgtPt) ;插入点
(cons 40 Hight) ;文字高度
)
)
)
)
)
(vla-endundomark DOC)
(princ)
) ferious 发表于 2023-4-21 08:15
(defun C:TTT4 (/ DOC SS i en LayNam StaPt EndPt TgtPt Hight)
(vl-load-com)
(setq DOC (vla-ge ...
:handshake感谢啊
页:
[1]
2