求新建一个图层，并且这个图层颜色都跟已有图层颜色设置不一样

品茗新秀

1.就是新建一个图层，并且图层颜色都跟已有颜色不一样 2.这个新建图层为当前层 图层名用户输入

vectra

1. (defun get-layer-colors        (/ color colors layers)
   
2.   (setq        layers
   
3.          (vla-get-layers
   
4.            (vla-get-activedocument (vlax-get-acad-object))
   
5.          )
   
6.   )
   
7. 
   
8.   (vlax-for layer layers
   
9.     (setq color (vla-get-color layer))
   
10.     (if        (not (member color colors))
    
11.       (setq colors (cons color colors))
    
12.     )
    
13.   )
    
14.   colors
    
15. )
    
16. 
    
17. 
    
18. (defun pick-unique-color (colors / color do)
    
19.   (setq        color 1
    
20.         do t
    
21.   )
    
22.   (while do
    
23.     (if        (not (member color colors))
    
24.       (setq do nil)
    
25.       (setq color (1+ color))
    
26.     )
    
27.   )
    
28.   color
    
29. )
    
30. 
    
31. 
    
32. (defun create-layer (name / color layer layers)
    
33.   (setq        layers (vla-get-layers
    
34.                  (vla-get-activedocument (vlax-get-acad-object))
    
35.                )
    
36.         color  (pick-unique-color (get-layer-colors))
    
37.   )
    
38.   (if (and
    
39.         (<= color 255)
    
40.         (/= (type (vl-catch-all-apply 'vla-item (list layers name)))
    
41.             'vla-object
    
42.         )
    
43.       )
    
44.     (progn
    
45.       (setq layer (vla-add layers name))
    
46.       (vla-put-color layer color)
    
47.       layer
    
48.     )
    
49.   )
    
50. )
    
51. 
    
52. 
    
53. (defun c:tt (/ name)
    
54.   (setq name (getstring "输入图层名称:"))
    
55.   (if (null (create-layer name))
    
56.     (princ "图层已存在或无独特颜色，未创建新图层。")
    
57.   )
    
58.   (princ)
    
59. )

(defun get-layer-colors        (/ color colors layers)<br />   (setq        layers<br />          (vla-get-layers<br />            (vla-get-activedocument (vlax-get-acad-object))<br />          )<br />   )<br /> <br />   (vlax-for layer layers<br />     (setq color (vla-get-color layer))<br />     (if        (not (member color colors))<br />       (setq colors (cons color colors))<br />     )<br />   )<br />   colors<br /> )<br /> <br /> <br /> (defun pick-unique-color (colors / color do)<br />   (setq        color 1<br />         do t<br />   )<br />   (while do<br />     (if        (not (member color colors))<br />       (setq do nil)<br />       (setq color (1+ color))<br />     )<br />   )<br />   color<br /> )<br /> <br /> <br /> (defun create-layer (name / color layer layers)<br />   (setq        layers (vla-get-layers<br />                  (vla-get-activedocument (vlax-get-acad-object))<br />                )<br />         color  (pick-unique-color (get-layer-colors))<br />   )<br />   (if (and<br />         (<= color 255)<br />         (/= (type (vl-catch-all-apply 'vla-item (list layers name)))<br />             'vla-object<br />         )<br />       )<br />     (progn<br />       (setq layer (vla-add layers name))<br />       (vla-put-color layer color)<br />       layer<br />     )<br />   )<br /> )<br /> <br /> <br /> (defun c:tt (/ name)<br />   (setq name (getstring "输入图层名称:"))<br />   (if (null (create-layer name))<br />     (princ "图层已存在或无独特颜色，未创建新图层。")<br />   )<br />   (princ)<br /> )

自贡黄明儒

这个容易，你先查询已经使用过的颜色

品茗新秀

自贡黄明儒 发表于 2014-12-10 16:56
这个容易，你先查询已经使用过的颜色

就是程序能检查已使用的颜色，然后增加一个不一样的颜色，如果该颜色不满，就手动改一下

品茗新秀

难的是跟已有颜色不一样，搞了半天几搞几来

mjz521yy

这个容易，你先查询已经使用过的颜色

llsheng_73

1. (defun c:tt(/ sll snl la co)
   
2.   (Setq sll(TblNext"layer"T))
   
3.   (While(SetQ snl(Cons(list(Cdr(Assoc 2 sll))(Cdr(Assoc 62 sll)))snl)sll(TblNext"layer"nil)))
   
4.   (setq snl(list(mapcar'car snl)(mapcar'cadr snl))la""co 1)
   
5.   (while(and(< co 256)(progn(while(tblsearch"layer"(setq la(getstring(if(<(length(car snl))8)(strcat"\n已有图层名["(apply'strcat(mapcar'(lambda(x)(strcat","x))(reverse(car snl))))"]:")
   
6.                                                              (strcat"\n上次图层名["(caar snl)"]:"))))(car snl))(alert(strcat"图层"la"已存在")))(/=""la))la)
   
7.     (while(member co(last snl))(setq co(1+ co)))
   
8.     (if(< co 257)
   
9.       (progn(entmakex(list'(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")(cons 62 co)'(70 . 0)(cons 2 la)))
   
10.         (setq snl(mapcar'(lambda(x y)(cons x y))(list la co)snl)))
    
11.       (setq la"")))
    
12.   )

(defun c:tt(/ sll snl la co)<br />   (Setq sll(TblNext"layer"T))<br />   (While(SetQ snl(Cons(list(Cdr(Assoc 2 sll))(Cdr(Assoc 62 sll)))snl)sll(TblNext"layer"nil)))<br />   (setq snl(list(mapcar'car snl)(mapcar'cadr snl))la""co 1)<br />   (while(and(< co 256)(progn(while(tblsearch"layer"(setq la(getstring(if(<(length(car snl))8)(strcat"\n已有图层名["(apply'strcat(mapcar'(lambda(x)(strcat","x))(reverse(car snl))))"]:")<br />                                                              (strcat"\n上次图层名["(caar snl)"]:"))))(car snl))(alert(strcat"图层"la"已存在")))(/=""la))la)<br />     (while(member co(last snl))(setq co(1+ co)))<br />     (if(< co 257)<br />       (progn(entmakex(list'(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")(cons 62 co)'(70 . 0)(cons 2 la)))<br />         (setq snl(mapcar'(lambda(x y)(cons x y))(list la co)snl)))<br />       (setq la"")))<br />   )

品茗新秀

llsheng_73 发表于 2014-12-11 17:21

你好，输入图层名后如何此图即为当前图层，我改了一下，跳不到当前图层

品茗新秀

llsheng_73 发表于 2014-12-11 17:21

主要是不能将输入的图层为当前图层

品茗新秀

我加了(setvar "clayer"怎么还没用