关于按实体颜色新建图层

lisp_beginner

大家好，
我有一些图，每个图层上都有不同的颜色的实体，比如：
能不能有个工具，把所有图层上的实体按照颜色号加上层名，建立个新层？
比如：
广场 3
广场 256
广场 7

铺装 4
铺装 5
.....

newer

1. (defun c:tt ( / c e i s )
   
2.     (if (setq s (ssget "_:L"))
   
3.         (repeat (setq i (sslength s))
   
4.             (setq e (entget (ssname s (setq i (1- i)))))
   
5.             (if (setq c (cdr (assoc 62 e)))
   
6.                 (entmod (subst (cons 8 (strcat (cdr (assoc 8 e)) " " (itoa c))) (assoc 8 e) e))
   
7.             )
   
8.         )
   
9.     )
   
10.     (princ)
    
11. )
    
12. 
    

(defun c:tt ( / c e i s )<br />     (if (setq s (ssget "_:L"))<br />         (repeat (setq i (sslength s))<br />             (setq e (entget (ssname s (setq i (1- i)))))<br />             (if (setq c (cdr (assoc 62 e)))<br />                 (entmod (subst (cons 8 (strcat (cdr (assoc 8 e)) " " (itoa c))) (assoc 8 e) e))<br />             )<br />         )<br />     )<br />     (princ)<br /> )<br /> <br />

Lisphk

VLISP的

1. (defun c:tt (/ *error* ss acDoc layerName)
   
2.   (defun *error* (msg)
   
3.     (if acDoc (vla-endundomark acDoc))
   
4.     (cond ((not msg))                                                  
   
5.           ((member msg '("Function cancelled" "quit / exit abort")))   
   
6.           ((princ (strcat "\n** Error: " msg " ** ")))                  
   
7.     )
   
8.     (princ)
   
9.   )
   
10. 
    
11.   (if (setq ss (ssget "_:L"))
    
12.     (progn
    
13.       (vla-startundomark
    
14.         (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
    
15.       )
    
16.       (vlax-for x (setq ss (vla-get-activeselectionset acDoc))
    
17.         (if
    
18.           (not (tblsearch "layer"
    
19.                           (setq layerName (strcat (vla-get-layer x)
    
20.                                                   " "
    
21.                                                   (itoa (vla-get-color x))
    
22.                                           )
    
23.                           )
    
24.                )
    
25.           )
    
26.            (vla-add (vla-get-layers acDoc) layerName)
    
27.         )
    
28.         (vla-put-layer x layerName)
    
29.       )
    
30.       (vla-delete ss)
    
31.     )
    
32.   )
    
33.   (*error* nil)
    
34. )
    
35. 
    

(defun c:tt (/ *error* ss acDoc layerName)<br />   (defun *error* (msg)<br />     (if acDoc (vla-endundomark acDoc))<br />     (cond ((not msg))                                                  <br />           ((member msg '("Function cancelled" "quit / exit abort")))    <br />           ((princ (strcat "\n** Error: " msg " ** ")))                  <br />     )<br />     (princ)<br />   )<br /> <br />   (if (setq ss (ssget "_:L"))<br />     (progn<br />       (vla-startundomark<br />         (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))<br />       )<br />       (vlax-for x (setq ss (vla-get-activeselectionset acDoc))<br />         (if<br />           (not (tblsearch "layer"<br />                           (setq layerName (strcat (vla-get-layer x)<br />                                                   " "<br />                                                   (itoa (vla-get-color x))<br />                                           )<br />                           )<br />                )<br />           )<br />            (vla-add (vla-get-layers acDoc) layerName)<br />         )<br />         (vla-put-layer x layerName)<br />       )<br />       (vla-delete ss)<br />     )<br />   )<br />   (*error* nil)<br /> )<br /> <br />

iLisp

(if (not (setq c (assoc 62 e)) ) (setq c 256))
(entmod ....)

Lispboy

iLisp 发表于 2016-9-12 18:33
(if (not (setq c (assoc 62 e)) ) (setq c 256))
(entmod ....)

256不应该选，依楼主意思，如果BYLAYER也改层了，那么原来的层就空了。BYLAYER不处理还都在原层。

xdcad9819

newer 发表于 2016-9-12 09:42

老师您好，能不能请您看看根据线条的起点和终点来建立图层，
http://bbs.xdcad.net/thread-725628-1-1.html
谢谢