按颜色选择
这个写了半天，终于写出来了，那位牛人能把我这个改精简点吗？;按颜色选择
(defun c:xyc ()
(setq txh 1)
(while txh
(setq object (entsel "\n请选过滤颜色对象"))
(if (= object nil)
nil
(setq txh nil)
)
)
(setq txh 1)
(while txh
(setq ss (ssadd))
(if (= ss nil)
nil
(setq txh nil)
)
)
(if (= (assoc 62 (entget (car object))) nil);如果图元颜色为随层
(progn
(setq object_Name (cdr (assoc 8 (entget (car object)))));提取图元图层名
(setq object_Color (cdr (assoc 62 (tblsearch "layer" object_Name))));提取图层颜色
)
(progn
(setq object_Color (cdr (assoc 62 (entget (car object)))));提取图元颜色
)
)
(setq ss1 (ssget));新建选择集
(setq xh 0)
(repeat (sslength ss1);循环选择集的每一个图元
(setq Object_Color2 (cdr (assoc 62 (entget (ssname ss1 xh)))));图元颜色
(if (= Object_Color2 nil);如果图元颜色为随层
(progn
(setq object_Name (cdr (assoc 8 (entget (ssname ss1 xh)))));提取图元图层名
(setq object_Color2 (cdr (assoc 62 (tblsearch "layer" object_Name))));提取图层颜色
(if (= object_Color2 object_Color)
(ssadd (ssname ss1 xh) ss);加入到选择集
)
)
(progn
(if (= object_Color2 object_Color)
(ssadd (ssname ss1 xh) ss);加入到选择集
)
)
)
(setq xh (+ xh 1))
)
(sssetfirst nil ss)
(princ (strcat "\n已选择" (rtos (sslength ss) 2 4) "个对象"))
(princ)
)
本帖最后由 kucha007 于 2022-12-4 14:00 编辑
kucha007 发表于 2022-11-17 22:45
Lee Mac写的，点选确定颜色，然后选择同色或相同色图层中颜色随层的对象
改了一下，支持多选或者先选(但得先勾选“先选择后执行”)
PS:代码有误，还在想如何合并选择集= =
(setvar "PICKFIRST" 1);勾选先选择后执行(defun c:TT (/ Old_Cmd Doc ss Cols co Dxf Lst sss)
(vl-load-com)
(if (not (setq ss (ssget "i")))
(setq ss (ssget))
)
(setq Old_Cmd (getvar "cmdecho"))
(setq Doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-startundomark Doc) ;记录编组
(setvar "cmdecho" 0)
(if ss
(progn
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq Cols (cons
(cond
((cdr (assoc 62 (entget e))))
((abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget e))))))))
)
Cols
)
)
)
(foreach co Cols
(while (setq Dxf (tblnext "LAYER" (null Dxf)))
(if (= co (abs (cdr (assoc 62 Dxf))))
(setq Lst (cons "," (cons (cdr (assoc 2 Dxf)) Lst)))
)
);获取颜色的图层
(setq sss
(ssget "_X"
(if Lst
(list
(cons -4 "<OR")
(cons -4 "<AND")
(cons 62 co)
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab)) '(410 . "Model")
)
(cons -4 "AND>")
(cons -4 "<AND")
(cons 62 256)
(cons 8 (apply 'strcat (cdr Lst)))
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab)) '(410 . "Model")
)
(cons -4 "AND>")
(cons -4 "OR>")
)
(list (cons 62 co))
)
)
)
(if (> (sslength sss) 0)(sssetfirst nil sss))
)
)
)
(setvar "cmdecho" Old_Cmd)
(vla-endundomark Doc) ;结束编组
(princ)
)
尒樣僮 发表于 2018-3-15 09:42
谢谢楼上两位的帮忙一下看不懂的慢慢理解
地板的代码是使用CAD自带的过滤选择系统，可以一次选定结果不用排查（不满足条件的对象直接无法选中）
5#代码仅演示代码精简优化（差不多少了一半的行数） 对象过滤还是用SSGET这个函数比较有效率，楼主不妨试试。
另外所谓的优化和程序精简是不一样的，优化后的程序比当前程序更长也是可能的。 我刚开始写就是用ssget写的 但是图元为随层我就弄不好了 要取的选择图元的所有图层 再找符合颜色的图层下图元为随层的图元
我的水平就只有这样了 本帖最后由 namezg 于 2018-3-15 18:15 编辑
;;;获取对象颜色函数
;(setq col (GetColor (setq en (car (entsel)))))
(defun GetColor (en / dxf col)
(setq dxf (entget en))
(if (not (setq col (cdr (assoc 62 dxf))))
(setq col (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 dxf))))))
)
col
)
;获得颜色为指定颜色的选择集(包括随层对象，包括块对象)
;col -- 颜色索引(0-256)
;(setq ss (GetColorSS (setq col 4)))
(defun GetColorSS (col / Layers laystr lay ss)
(setq Layers (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq laystr "")
(vlax-for item Layers
(setq lay (vla-get-Name item))
(if (= (vla-get-Color item) col)
(if (= laystr "")
(setq laystr lay)
(setq laystr (strcat laystr "," lay))
)
)
)
(if (= laystr "")
(setq ss (ssget (list (cons 62 col))))
(setq ss
(ssget
(list
'(-4 . "<OR")
(cons 62 col)
'(-4 . "<AND")
(cons 8 laystr)
'(62 . 256)
'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
)
)
;选择与指定对象颜色相同的对象(包括随层对象，包括块对象)
(defun c:GetSameColorSS ( / en ss n)
(vl-load-com)
(if (setq en (car (entsel "\n请选择源对象：")))
(setq ss (GetColorSS (GetColor en)))
)
(sssetfirst nil ss)
(if ss
(setq n (sslength ss))
(setq n 0)
)
(princ (strcat "\n选择与指定对象颜色相同的对象" (rtos n 2 4) "个。"))
(princ)
)
(defun c:xyc ()
(while (null (setq obj (entsel "\n请选过滤颜色对象"))))
(setq dxf (entget (car obj))
c (cdr (assoc 62 dxf))
)
(if (null c) ;如果图元颜色为随层
(setq c (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 dxf)))))) ;提取图层颜色
)
(setq ss1 (ssget)
ss(ssadd)
) ;新建选择集
(repeat (setq xh (sslength ss1)) ;循环选择集的每一个图元
(setq dxf (entget (ssname ss1 (setq xh (1- xh))))
c2(cdr (assoc 62 dxf))
) ;图元颜色
(if (null c2) ;如果图元颜色为随层
(setq c2 (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 dxf)))))) ;提取图层颜色
)
(if (= c2 c)
(ssadd (ssname ss1 xh) ss) ;加入到选择集
)
)
(sssetfirst nil ss)
(princ (strcat "\n已选择" (itoa (sslength ss)) "个对象"))
(princ)
) 谢谢楼上两位的帮忙一下看不懂的慢慢理解 ;; 按颜色选择
(defun c:tt ()
(defun GetCo (s0 / a la co en)
(setq en (entget s0))
(if(setq a (assoc 62 en))
(cdr a)
(cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 en)))))
)
)
(if (progn(setq s0 (car (entsel "\n请选过滤颜色对象: ")))
(redraw s0 3)
(setq ss1 (ssget))
)
(progn (setq co (GetCo s0) ss (ssadd) i-1)
(while (setq s1 (ssname ss1 (setq i (1+ i))))
(if (= (GetCo s1) co) (ssadd s1 ss))
)
(sssetfirst nil ss)
(princ (strcat "\n已选择" (itoa (sslength ss)) "个对象"))
)
)
(princ)
) 感谢，终于找到了想要的功能