求在图中指定地方生成已有图层的图层名文字，且图层名即在对应的图层，文字上下顺...

品茗新秀

求在图中指定地方生成已有图层的图层名文字，且图层名即在对应的图层，

SunSpring

品茗新秀 发表于 2014-3-23 18:54
图层生成是这个样子，如果能排序就好了，如图圈圈的应在最后

1. (defun c:lsa ( / layerdata layerlst layername pt textsize)
   
2.   (defun maketext (locationpoint textheight text rowtype)
   
3.     (entmake (list '(0 . "TEXT")
   
4.                    '(100 . "AcDbText")
   
5.                     (cons 40 textheight)
   
6.                    '(41 . 0.8)
   
7.                     (cons 1 text)
   
8.                     (cons 72 rowtype)
   
9.                    '(10 0.0 0.0 0.0)
   
10.                     (cons 11 (trans locationpoint 1 0))
    
11.                    '(73 . 2)
    
12.              )
    
13.     )
    
14.   )
    
15.   (setq textsize (* (getvar "dimscale") (getvar "textsize")))
    
16.   (while (setq layerdata (tblnext "layer" (null layerdata)))
    
17.     (setq layername (cdr (assoc 2 layerdata)))
    
18.     (setq layerlst (cons layername layerlst))
    
19.   )
    
20.   (if (setq pt (getpoint "\n 指定插入点:"))
    
21.     (foreach layername (acad_strlsort layerlst)
    
22.       (setvar "clayer" layername)
    
23.       (maketext pt textsize layername 0)
    
24.       (setq pt (list (car pt) (- (cadr pt) (* 2 textsize))))
    
25.     )
    
26.   )
    
27.   (princ)
    
28. )

(defun c:lsa ( / layerdata layerlst layername pt textsize)<br />   (defun maketext (locationpoint textheight text rowtype)<br />     (entmake (list '(0 . "TEXT")<br />                    '(100 . "AcDbText")<br />                     (cons 40 textheight)<br />                    '(41 . 0.8)<br />                     (cons 1 text)<br />                     (cons 72 rowtype)<br />                    '(10 0.0 0.0 0.0)<br />                     (cons 11 (trans locationpoint 1 0))<br />                    '(73 . 2)<br />              )<br />     )<br />   )<br />   (setq textsize (* (getvar "dimscale") (getvar "textsize")))<br />   (while (setq layerdata (tblnext "layer" (null layerdata)))<br />     (setq layername (cdr (assoc 2 layerdata)))<br />     (setq layerlst (cons layername layerlst))<br />   )<br />   (if (setq pt (getpoint "\n 指定插入点:"))<br />     (foreach layername (acad_strlsort layerlst)<br />       (setvar "clayer" layername)<br />       (maketext pt textsize layername 0)<br />       (setq pt (list (car pt) (- (cadr pt) (* 2 textsize))))<br />     )<br />   )<br />   (princ)<br /> )

这下应该可以了.

llsheng_73

做类似的图例用？

品茗新秀

这个看样子难度较大，顶出高手

lpl

我觉得院长应该出手了？？

SunSpring

1. (defun c:lsa ( / layerdata layername pt textsize)
   
2.   (defun maketext (locationpoint textheight text rowtype)
   
3.     (entmake (list '(0 . "TEXT")
   
4.                    '(100 . "AcDbText")
   
5.                     (cons 40 textheight)
   
6.                    '(41 . 0.8)
   
7.                     (cons 1 text)
   
8.                     (cons 72 rowtype)
   
9.                    '(10 0.0 0.0 0.0)
   
10.                     (cons 11 (trans locationpoint 1 0))
    
11.                    '(73 . 2)
    
12.              )
    
13.     )
    
14.   )
    
15.   (setq textsize (* (getvar "dimscale") (getvar "textsize")))
    
16.   (if (setq pt (getpoint "\n 指定插入点:"))
    
17.     (while (setq layerdata (tblnext "layer" (null layerdata)))
    
18.       (setq layername (cdr (assoc 2 layerdata)))
    
19.       (setvar "clayer" layername)
    
20.       (maketext pt textsize layername 0)
    
21.       (setq pt (list (car pt) (- (cadr pt) (* 2 textsize))))
    
22.     )
    
23.   )
    
24.   (princ)
    
25. )

(defun c:lsa ( / layerdata layername pt textsize)<br />   (defun maketext (locationpoint textheight text rowtype)<br />     (entmake (list '(0 . "TEXT")<br />                    '(100 . "AcDbText")<br />                     (cons 40 textheight)<br />                    '(41 . 0.8)<br />                     (cons 1 text)<br />                     (cons 72 rowtype)<br />                    '(10 0.0 0.0 0.0)<br />                     (cons 11 (trans locationpoint 1 0))<br />                    '(73 . 2)<br />              )<br />     )<br />   )<br />   (setq textsize (* (getvar "dimscale") (getvar "textsize")))<br />   (if (setq pt (getpoint "\n 指定插入点:"))<br />     (while (setq layerdata (tblnext "layer" (null layerdata)))<br />       (setq layername (cdr (assoc 2 layerdata)))<br />       (setvar "clayer" layername)<br />       (maketext pt textsize layername 0)<br />       (setq pt (list (car pt) (- (cadr pt) (* 2 textsize))))<br />     )<br />   )<br />   (princ)<br /> )

不知道是不是这样的效果,试下.

品茗新秀

SunSpring 发表于 2014-3-23 16:46
不知道是不是这样的效果,试下.

图层生成是这个样子，如果能排序就好了，如图圈圈的应在最后

q3_2006

品茗新秀 发表于 2014-3-23 18:54
图层生成是这个样子，如果能排序就好了，如图圈圈的应在最后

加一句就行...
(defun c:lsa ( / layerdata layerlst layername pt textsize)
  (defun maketext (locationpoint textheight text rowtype)
    (entmake (list '(0 . "TEXT")
                   '(100 . "AcDbText")
                    (cons 40 textheight)
                   '(41 . 0.8)
                    (cons 1 text)
                    (cons 72 rowtype)
                   '(10 0.0 0.0 0.0)
                    (cons 11 (trans locationpoint 1 0))
                   '(73 . 2)
             )
    )
  )
  (setq textsize (* (getvar "dimscale") (getvar "textsize")))
  (while (setq layerdata (tblnext "layer" (null layerdata)))
    (setq layername (cdr (assoc 2 layerdata)))
    (setq layerlst (cons layername layerlst))
  )
  (setq layerlst (vl-sort layerlst '<))
  (if (setq pt (getpoint "\n 指定插入点:"))
    (foreach layername (acad_strlsort layerlst)
      (setvar "clayer" layername)
      (maketext pt textsize layername 0)
      (setq pt (list (car pt) (- (cadr pt) (* 2 textsize))))
    )
  )
  (princ)
)