征求：图层归统程序源码....
本帖最后由 尘缘一生 于 2015-12-14 18:07 编辑问题提出：
一：工作初始：
我们画图初始坏境，设置了一定量图层：颜色、线型。
二：工作过程产生新实体入层，然而，新实体的颜色、线型，并没有和初始图层完全相符。
三：求这样功能的lisp :
选择一范围内所有实体，判断每个实体的：颜色，线型；假如这样颜色和线型的图层已存在，就落去，否则，就建立这样颜色+线型的图层出来（新层名就用颜色号），并把这个实体改到新层去......；新增加的图层程序自动记录，下一实体判断要比较的图层，多了这一个.......；如此循环.......
四：目的与结果：
程序处理完，保证：颜色和线型相同的实体，存在唯一的该层上。颜色不同不在该层，线型不同也不在该层。
*******************************************************************
我在本论坛找过"按色分层”源码如下，假如如此使用，虽然按颜色分了层，但却把线型搞乱了，因此，需要完善线型问题，连线型要考虑在内一起判断......；改造成“按色、线分层”出来！(defun C:DDDD (/ *DOC *OBJ *LAY blocks layers)
(setvar "CMDECHO" 0)
(vl-load-com)
(setq *OBJ (vlax-get-acad-object))
(setq *DOC (vla-get-activedocument *OBJ))
(setq *LAY (vla-get-layers *DOC)) ;取得层集合
(table)
(setq blocks (vla-get-blocks *DOC)) ;取得块集合
(vlax-for block blocks ;遍历块集合
(vlax-for n block ;遍历单个块
(ccb n)
)
)
(setvar "CMDECHO" 1)
(princ)
)
(defun ccb (object / colour laynam laycol)
(setq colour (itoa (vla-get-color object))) ;取得物体颜色号
(cond
( (or (= colour "256") (= colour "0")) ;如果物体颜色随层或随块
(setq laynam (vla-get-layer object)) ;取得物体所在层名
(setq laycol (cdr (assoc laynam layers)));取得层颜色
(setq colour (itoa laycol))
(ML)
)
( (ML)
(vla-put-color object 256) ;否则改变物体颜色为随层
)
)
(vla-put-layer object colour) ;对物体改层到颜色号层
)
(defun ML (/ layobj)
(if (not (assoc colour layers)) ;如果颜色号不在图层表中
(progn
(setq layers (cons (cons colour laycol) layers))
;重新构造图层表
(setq layobj (vla-add *LAY colour ) ) ;创建颜色号图层
(vla-put-color layobj colour)
;对颜色号层赋色
)
)
)
(defun table (/ name color Nname)
(vlax-for n *LAY ;遍历层集合
(setq name (vla-get-name n)) ;取得层名
(setq color (vla-get-color n)) ;取得层颜色
(setq layers (cons (cons name color) layers));获得层名和颜色号表
(setq Nname (read name))
(if (= (type Nname) (type 1)) ;如果层名是整数
(if (= (strlen (itoa Nname)) (strlen name))
(if (and (> Nname 0) (< Nname 256)) ;並且>0,<256
(if (/= color Nname) ;如果层颜色不等于层名
(vla-put-color n Nname) ;则改层颜色为层名
)
)
)
)
)
) 本帖最后由 wzg356 于 2015-12-15 01:16 编辑
颜色相同、线型不同的层如何取名区分？
下面的是通通重来一遍;按颜色+线型建层重新归拢(newla)
;是否所有对象均有线型属性没考虑，颜色随块没考虑（我搞不定）
(defun newla ( / ss i ee obj pro1 pro2 pro3 pro4 pro5 Laname)
(setq ss(ssget))
(setq i 0)
(while (setq ee (ssname ss i))
(setq obj (vlax-ename->vla-object ee)
pro1 (vlax-get-property obj "Layer")
pro2(vlax-get-property obj "Color")
pro3(vlax-get-property obj "Linetype")
pro4(cdr (assoc 62 (tblsearch "LAYER" pro1)));;图元现在层颜色
pro5(cdr (assoc 6 (tblsearch "LAYER" pro1)));;图元现在层线型
)
(setq pro2(if (equal pro2 256) pro4 pro2));图元颜色
(setq pro3(if (equal pro3 "ByLayer") pro5 pro3));图元线型
(setq Laname
(strcat
"色" (rtospro2 20);图元颜色
"+线"pro3 ;图元线型
)
);颜色+线型的图层名
(If (= (Tblsearch "layer" Laname) nil)
;;;颜色+线型取名定义新图层
(command "-layer" "n" Laname "c" pro2 Laname "l" pro3 Laname "")
)
(if(equal pro1 Laname)nil(command "chprop" ee "" "la" Laname ""));;把东东放进去
(setq i (+ i 1))
)
) 本帖最后由 尘缘一生 于 2015-12-15 16:23 编辑
wzg356 发表于 2015-12-14 22:37 static/image/common/back.gif
颜色相同、线型不同的层如何取名区分？
下面的是通通重来一遍
我仅会普通编程，见谅，不是为建立新层，是该建的建，不需要建的不建，并不动实体的层，不符合的才建立它，并把它归层过去。
取得现已存在的：层表，颜色和线型，判断存在实体是否相符，不相符-->建立该层-->把该实体移到该层。
关键是下一实体：
A:要是正好符合已有的存在层，不动它B:符合本程序新建立的层，就移动到该层C:假如都没有符合它的层存在-->循环建立------> ;另一种，拿对象颜色 线型与已有层颜色 线型比较
;==========================
;取得已有层的属性表
;返回((层名1 颜色 线型)(层名2 颜色 线型)......)
(defun getlalst ( / TBL TBL_LIST )
(while (setq TBL (tblnext "LAYER" (null TBL)))
(setq TBL_LIST
(cons
(list
(cdr (assoc 2 TBL))
(cdr (assoc 62 TBL))
(cdr (assoc 6 TBL))
)
TBL_LIST
)
)
)
)
;取得图元的图层+颜色+线型信息
;(getenpro (car(entsel)))
;返回(层名 颜色 线型)
(defun getenpro (ee / obj pro1 pro2 pro3 pro4 pro5)
(setq obj (vlax-ename->vla-object ee)
pro1 (vlax-get-property obj "Layer")
pro2(vlax-get-property obj "Color")
pro3(vlax-get-property obj "Linetype")
pro4(cdr (assoc 62 (tblsearch "LAYER" pro1)));;图元现在层颜色
pro5(cdr (assoc 6 (tblsearch "LAYER" pro1)));;图元现在层线型
)
(listpro1 ;图层
(if (equal pro2 256) pro4 pro2);图元颜色
(if (equal pro3 "ByLayer") pro5 pro3);图元线型
)
)
(defun c:newla1 ( / ss i ee lalst enlst co lsty lalst1 a Laname)
(setq ss(ssget))
(setq i 0)
(while (setq ee (ssname ss i))
(setq lalst (getlalst) lalst1 nil)
(setq enlst (getenpro ee)
co(cadr enlst);图元颜色
lsty (caddr enlst);图元线型
)
(if (member enlst lalst )
nil
(progn
(foreach a lalst
(if (equal (cdr enlst) (cdr a)) (setq lalst1(cons a lalst1)))
);颜色线型相同的层，可能有多个
(if lalst1
(command "chprop" ee "" "la" (car lalst1) "")
(progn
(setq Laname(strcat "色" (rtos co 20)"+线" lsty ))
;颜色+线型的图层名
(If (= (Tblsearch "layer" Laname) nil)
(command "-layer"
"n" Laname
"c" co Laname
"l" lsty Laname ""
)
);;;颜色+线型取名定义新图层
(command "chprop" ee "" "la" Laname "")
)
)
)
)
(setq i (+ i 1))
)
) 本帖最后由 wzg356 于 2015-12-15 14:30 编辑
有循环的呀？选择集里面逐个判断。
本身你的逻辑有问题，如果已有层颜色+线型相同的有多个，难道要搞一个图层合并？拿不如用沙发楼的。
第一个（沙发）：类似于把已有层按颜色+线型更名，每刷一遍，选择的对象自动按对象颜色、线型归入相应的层。
第二个（楼上)：只按对象颜色、线型与已有层颜色+线型对比并归入相应层（如果颜色+线型相同的层有多个，只选一个放进去)，或按颜色、线型建新层并把相应图元放进去。
也就是第一个统一层名规则
第二个只管层的颜色+线型，新建层颜色+线型不会与已有层颜色+线型重复（已有的是否重复不管)，但新层名可能与已有层名重复就没考虑了，只是概率极小，可以用 wzg356 发表于 2015-12-15 14:05 static/image/common/back.gif
有循环的呀？选择集里面逐个判断。
本身你的逻辑有问题，如果已有层颜色+线型相同的有多个，难道要搞一个 ...
假如2个实体，颜色与线型均相同，存在于已经存在得两个层上，我们不管它，为什么要管？有必要吗？因为他们的颜色与线型与层的定义同，没错！
为了优化？归并层，当然好，因为归并层的代码早有了。
我没有发现存在一个代码能把颜色和线型与所存在得层设置不同的，变对了它，因为，没有这个功能，任何代码，把实体按颜色分层的，都无有任何意义，试想以下：
1:我一个实体，为LINE ,色为红色，线型为 实线，存在层 1上
2:我还有一个实体，为LINE， 色为红色，线型为“轴线”，也存在层1上，这个实体不对，因为层1是存实线且红色的！
就要把实体变对与层设置相符得去，不用管层最后是多少个，多又怎么样？嫌多，归并即可，有代码了，哪么，最基本的实体都变不过去，还归并个鸟？ 第二个还不行？ 光图层的话cad的标准检查就可以吧 本帖最后由 尘缘一生 于 2015-12-15 17:23 编辑
wzg356 发表于 2015-12-15 16:53 static/image/common/back.gif
第二个还不行？
我确实看不大懂,但从判断部分啥的，觉得很正确的，但我实验运行不了，变量说错误中断，我改了下循环条件，也不行。看运行信息啊，输入层名为“BYAYER”，然后就中断了。
我CAD初始存在的层，线型都是随层的。;另一种，拿对象颜色 线型与已有层颜色 线型比较
;==========================
;取得已有层的属性表
;返回((层名1 颜色 线型)(层名2 颜色 线型)......)
(defun getlalst ( / TBL TBL_LIST )
(while (setq TBL (tblnext "LAYER" (null TBL)))
(setq TBL_LIST
(cons
(list
(cdr (assoc 2 TBL))
(cdr (assoc 62 TBL))
(cdr (assoc 6 TBL))
)
TBL_LIST
)
)
)
)
;取得图元的图层+颜色+线型信息
;(getenpro (car(entsel)))
;返回(层名 颜色 线型)
(defun getenpro (ee / obj pro1 pro2 pro3 pro4 pro5)
(setq obj (vlax-ename->vla-object ee)
pro1 (vlax-get-property obj "Layer")
pro2(vlax-get-property obj "Color")
pro3(vlax-get-property obj "Linetype")
pro4(cdr (assoc 62 (tblsearch "LAYER" pro1)));;图元现在层颜色
pro5(cdr (assoc 6 (tblsearch "LAYER" pro1)));;图元现在层线型
)
(listpro1 ;图层
(if (equal pro2 256) pro4 pro2);图元颜色
(if (equal pro3 "ByLayer") pro5 pro3);图元线型
)
)
(defun c:newla1 ( / ss i ee lalst enlst co lsty lalst1 a Laname)
(setq ss(ssget))
(setq n (sslength ss))
(setq i 0)
(while (< i n)
(setq ee (ssname ss i))
(setq lalst (getlalst) lalst1 nil)
(setq enlst (getenpro ee)
co(cadr enlst);图元颜色
lsty (caddr enlst);图元线型
)
(if (member enlst lalst )
nil
(progn
(foreach a lalst
(if (equal (cdr enlst) (cdr a)) (setq lalst1(cons a lalst1)))
);颜色线型相同的层，可能有多个
(if lalst1
(command "chprop" ee "" "la" (car lalst1) "")
(progn
(setq Laname(strcat "色" (rtos co 20)"+线" lsty ))
;颜色+线型的图层名
(If (= (Tblsearch "layer" Laname) nil)
(command "-layer"
"n" Laname
"c" co Laname
"l" lsty Laname ""
)
);;;颜色+线型取名定义新图层
(command "chprop" ee "" "la" Laname "")
)
)
)
)
(setq i (+ i 1))
)
)
尘缘一生 发表于 2015-12-15 16:38 static/image/common/back.gif
假如2个实体，颜色与线型均相同，存在于已经存在得两个层上，我们不管它，为什么要管？有必要吗？ ...
没法用图表示，我有一红色实体线，和一红色轴线，用哪个按色分层（一楼我发的代码），它却生成个新层，把这2个实体都收进去，却同时变成了实线，大错特错。
页:
[1]
2