标注图层名在线段右侧

nyistjz

给朋友做的一个小功能，希望能能更多人有用！

(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

最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist输入。
03-命令编组方便撤回

1. (defun C:TT (/ DOC SS i en LayNam StaPt EndPt TgtPt Hight)
   
2.   (vl-load-com)
   
3.   (setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))
   
4.   (vla-startundomark DOC)
   
5.     (if (setq SS (ssget '((0 . "*POLYLINE,LINE"))))
   
6.       (progn
   
7.         (initget (+ 1 2 4)) ;非空非零非负值
   
8.         (setq Hight (getdist "→请输入或量取文字高度："))
   
9.         (repeat (setq i (sslength SS))
   
10.           (setq en (ssname SS (setq i (1- i))))
    
11.           (setq LayNam (cdr (assoc 8 (entget en))))
    
12.           (setq StaPt (vlax-curve-getstartPoint (vlax-ename->vla-object en))) ; 起点坐标
    
13.           (setq EndPt (vlax-curve-getendPoint (vlax-ename->vla-object en))) ; 终点坐标
    
14.           (setq TgtPt (if (>= (car StaPt) (car EndPt)) StaPt EndPt))
    
15.           (setq TgtPt (mapcar
    
16.                         '(lambda (x y) (+ x y))
    
17.                         TgtPt
    
18.                         (list (* 0.5 Hight) (* -0.3 Hight) 0)
    
19.                       )
    
20.           )
    
21.           (entmake
    
22.             (list
    
23.               '(0 . "TEXT")
    
24.               (cons 1 LayNam) ;文字内容
    
25.               (cons 8 LayNam) ;图层名称
    
26.               (cons 10 TgtPt) ;插入点
    
27.               (cons 40 Hight) ;文字高度
    
28.             )
    
29.           )
    
30.         )
    
31.       )
    
32.     )
    
33.   (vla-endundomark DOC)
    
34.   (princ)
    
35. )
    
36. 
    

(defun C:TT (/ DOC SS i en LayNam StaPt EndPt TgtPt Hight)<br />   (vl-load-com)<br />   (setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))<br />   (vla-startundomark DOC)<br />     (if (setq SS (ssget '((0 . "*POLYLINE,LINE")))) <br />       (progn <br />         (initget (+ 1 2 4)) ;非空非零非负值<br />         (setq Hight (getdist "→请输入或量取文字高度："))<br />         (repeat (setq i (sslength SS)) <br />           (setq en (ssname SS (setq i (1- i))))<br />           (setq LayNam (cdr (assoc 8 (entget en))))<br />           (setq StaPt (vlax-curve-getstartPoint (vlax-ename->vla-object en))) ; 起点坐标<br />           (setq EndPt (vlax-curve-getendPoint (vlax-ename->vla-object en))) ; 终点坐标<br />           (setq TgtPt (if (>= (car StaPt) (car EndPt)) StaPt EndPt))<br />           (setq TgtPt (mapcar <br />                         '(lambda (x y) (+ x y))<br />                         TgtPt<br />                         (list (* 0.5 Hight) (* -0.3 Hight) 0)<br />                       )<br />           )<br />           (entmake <br />             (list <br />               '(0 . "TEXT")<br />               (cons 1 LayNam) ;文字内容<br />               (cons 8 LayNam) ;图层名称<br />               (cons 10 TgtPt) ;插入点<br />               (cons 40 Hight) ;文字高度<br />             )<br />           )<br />         )<br />       )<br />     )<br />   (vla-endundomark DOC)<br />   (princ)<br /> )<br /> <br />

alexmai

画线表示不理解，跟论坛中“提取图层名字”，是相同用法

2. ;;提取图层名字
   
3. (defun C:tcn (/ LST N PT)
   
4.   (setvar "cecolor" "bylayer")
   
5.   (setq LST (reverse (TABLE "LAYER")))
   
6.   (setq PT (getpoint "文字插入點: ")
   
7.         N 0
   
8.   )
   
9.   (foreach NAME LST
   
10.     (entmake (list '(0 . "TEXT") (cons 8 NAME) '(100 . "AcDbText") (cons 10
    
11.                                                                          (list
    
12.                                                                                (car PT)
    
13.                                                                                (-
    
14.                                                                                   (cadr PT) N
    
15.                                                                                )
    
16.                                                                          )
    
17.                                                                    ) '
    
18.                    (40 . 6) (cons 1 NAME)
    
19.              )
    
20.     )
    
21.     (setq N (+ N 10.0))
    
22.   )
    
23.   (princ)
    
24. )
    
25. 
    
26. (defun TABLE (S / D R)
    
27.   (while (setq D (tblnext S (null D)))
    
28.     (setq R (cons (cdr (assoc 2 D)) R))
    
29.   )
    
30. )

;;提取图层名字<br /> (defun C:tcn (/ LST N PT)<br />   (setvar "cecolor" "bylayer")<br />   (setq LST (reverse (TABLE "LAYER")))<br />   (setq PT (getpoint "文字插入點: ")<br />         N 0<br />   )<br />   (foreach NAME LST<br />     (entmake (list '(0 . "TEXT") (cons 8 NAME) '(100 . "AcDbText") (cons 10<br />                                                                          (list<br />                                                                                (car PT)<br />                                                                                (-<br />                                                                                   (cadr PT) N<br />                                                                                )<br />                                                                          )<br />                                                                    ) '<br />                    (40 . 6) (cons 1 NAME)<br />              )<br />     )<br />     (setq N (+ N 10.0))<br />   )<br />   (princ)<br /> )<br /> <br /> (defun TABLE (S / D R)<br />   (while (setq D (tblnext S (null D)))<br />     (setq R (cons (cdr (assoc 2 D)) R))<br />   )<br /> )

nyistjz

kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...

lxl217114

谢谢大佬分享实用功能

月下闲人

kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...

感谢大佬优化，输入命令选择对象后输入字高时出现乱码

ferious

kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...

你好，
首先，聊表谢意！谷雨快乐！

其次，附上GIF动图，直观，如有动图疑问，可查看下面链接教程；

Cad图块中线型比例修改 - AutoCAD工具插件 - AutoCAD论坛 - 明经CAD社区 - Powered by Discuz! (mjtd.com)
最后，能否将产生的文字放到公司标准的图层？

wlpkok

ferious 发表于 2023-4-20 16:39
你好，
首先，聊表谢意！谷雨快乐！

求个这个lisp，上面那个码复制了不行

aggdqty

kucha007 发表于 2023-4-15 23:09
最近可能会用到，就做了点改动。
01-获取首尾端点坐标，判断那个才是右侧端点。
02-文字高度改为GetDist ...

试了一下，很实用，谢谢

ferious

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

wlpkok

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 ...

感谢啊