设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 按颜色选择
123下一页
返回列表 发新帖
查看: 6729|回复: 22

[源码] 按颜色选择

[复制链接]
尒樣僮
发表于 2018-3-12 21:39:55 | 显示全部楼层 |阅读模式
这个写了半天，终于写出来了，那位牛人能把我这个改精简点吗？
  1. ;按颜色选择
  2. (defun c:xyc ()
  3.   (setq txh 1)
  4.   (while txh
  5.     (setq object (entsel "\n请选过滤颜色对象"))
  6.     (if (= object nil)
  7.       nil
  8.       (setq txh nil)
  9.     )
  10.   )
  11.   (setq txh 1)
  12.   (while txh
  13.     (setq ss (ssadd))
  14.     (if (= ss nil)
  15.       nil
  16.       (setq txh nil)
  17.     )
  18.   )
  19.   (if (= (assoc 62 (entget (car object))) nil);如果图元颜色为随层
  20.     (progn
  21.       (setq object_Name (cdr (assoc 8 (entget (car object)))));提取图元图层名
  22.       (setq object_Color (cdr (assoc 62 (tblsearch "layer" object_Name))));提取图层颜色
  23.     )
  24.     (progn
  25.       (setq object_Color (cdr (assoc 62 (entget (car object)))));提取图元颜色
  26.     )
  27.   )
  28.   (setq ss1 (ssget));新建选择集
  29.   (setq xh 0)
  30.   (repeat (sslength ss1);循环选择集的每一个图元
  31.     (setq Object_Color2 (cdr (assoc 62 (entget (ssname ss1 xh)))));图元颜色
  32.     (if (= Object_Color2 nil);如果图元颜色为随层
  33.       (progn
  34.         (setq object_Name (cdr (assoc 8 (entget (ssname ss1 xh)))));提取图元图层名
  35.         (setq object_Color2 (cdr (assoc 62 (tblsearch "layer" object_Name))));提取图层颜色
  36.         (if (= object_Color2 object_Color)
  37.           (ssadd (ssname ss1 xh) ss);加入到选择集
  38.         )
  39.       )
  40.       (progn
  41.         (if (= object_Color2 object_Color)
  42.           (ssadd (ssname ss1 xh) ss);加入到选择集
  43.         )
  44.       )
  45.     )
  46.     (setq xh (+ xh 1))
  47.   )
  48.   (sssetfirst nil ss)
  49.   (princ (strcat "\n已选择" (rtos (sslength ss) 2 4) "个对象"))
  50.   (princ)
  51. )

回复

使用道具 举报

kucha007
发表于 2022-11-17 23:27:21 | 显示全部楼层
本帖最后由 kucha007 于 2022-12-4 14:00 编辑
kucha007 发表于 2022-11-17 22:45
Lee Mac写的，点选确定颜色，然后选择同色或相同色图层中颜色随层的对象

改了一下，支持多选或者先选(但得先勾选“先选择后执行”)
PS:代码有误，还在想如何合并选择集= =
  1. (setvar "PICKFIRST" 1);勾选先选择后执行
  2. (defun c:TT (/ Old_Cmd Doc ss Cols co Dxf Lst sss)
  3.   (vl-load-com)
  4.   (if (not (setq ss (ssget "i")))
  5.       (setq ss (ssget))
  6.   )
  7.   (setq Old_Cmd (getvar "cmdecho"))
  8.   (setq Doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  9.   (vla-startundomark Doc) ;记录编组
  10.     (setvar "cmdecho" 0)
  11.     (if ss
  12.       (progn
  13.         (repeat (setq i (sslength ss))
  14.           (setq e (ssname ss (setq i (1- i))))
  15.           (setq Cols (cons
  16.                         (cond
  17.                             ((cdr (assoc 62 (entget e))))
  18.                             ((abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget e))))))))
  19.                         )
  20.                         Cols
  21.                     )
  22.           )
  23.         )
  24.         (foreach co Cols
  25.               (while (setq Dxf (tblnext "LAYER" (null Dxf)))
  26.                 (if (= co (abs (cdr (assoc 62 Dxf))))
  27.                   (setq Lst (cons "," (cons (cdr (assoc 2 Dxf)) Lst)))
  28.                 )
  29.               );获取颜色的图层
  30.               (setq sss
  31.                           (ssget "_X"
  32.                                 (if Lst
  33.                                   (list
  34.                                     (cons -4 "<OR")
  35.                                     (cons -4 "<AND")
  36.                                       (cons 62 co)
  37.                                       (if (= 1 (getvar 'cvport))
  38.                                         (cons 410 (getvar 'ctab)) '(410 . "Model")
  39.                                       )
  40.                                     (cons -4 "AND>")
  41.                                     (cons -4 "<AND")
  42.                                       (cons 62 256)
  43.                                       (cons 8 (apply 'strcat (cdr Lst)))
  44.                                       (if (= 1 (getvar 'cvport))
  45.                                         (cons 410 (getvar 'ctab)) '(410 . "Model")
  46.                                       )
  47.                                     (cons -4 "AND>")
  48.                                     (cons -4 "OR>")
  49.                                   )
  50.                                   (list (cons 62 co))
  51.                                 )
  52.                           )
  53.               )
  54.               (if (> (sslength sss) 0)(sssetfirst nil sss))
  55.         )
  56.       )
  57.     )
  58.     (setvar "cmdecho" Old_Cmd)
  59.   (vla-endundomark Doc) ;结束编组
  60.   (princ)
  61. )




回复 支持 0 反对 1

使用道具 举报

vectra
发表于 2018-3-15 10:27:27 | 显示全部楼层
尒樣僮 发表于 2018-3-15 09:42
谢谢楼上两位的帮忙  一下看不懂  的慢慢理解

地板的代码是使用CAD自带的过滤选择系统，可以一次选定结果不用排查（不满足条件的对象直接无法选中）

5#代码仅演示代码精简优化（差不多少了一半的行数）
回复 支持 0 反对 1

使用道具 举报

ghgh0130
发表于 2018-3-13 17:52:34 | 显示全部楼层
对象过滤还是用SSGET这个函数比较有效率，楼主不妨试试。
另外所谓的优化和程序精简是不一样的，优化后的程序比当前程序更长也是可能的。
回复 支持 反对

使用道具 举报

尒樣僮
 楼主| 发表于 2018-3-14 12:39:00 | 显示全部楼层
我刚开始写就是用ssget写的 但是图元为随层我就弄不好了 要取的选择图元的所有图层 再找符合颜色的图层下图元为随层的图元
我的水平就只有这样了
回复 支持 反对

使用道具 举报

namezg
发表于 2018-3-14 16:30:00 | 显示全部楼层
本帖最后由 namezg 于 2018-3-15 18:15 编辑

  1. ;;;获取对象颜色函数
  2. ;(setq col (GetColor (setq en (car (entsel)))))
  3. (defun GetColor (en / dxf col)
  4.   (setq dxf (entget en))
  5.   (if (not (setq col (cdr (assoc 62 dxf))))
  6.     (setq col (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 dxf))))))
  7.   )
  8.   col
  9. )
  10. ;获得颜色为指定颜色的选择集(包括随层对象，包括块对象)
  11. ;col -- 颜色索引(0-256)
  12. ;(setq ss (GetColorSS (setq col 4)))
  13. (defun GetColorSS (col / Layers laystr lay ss)
  14.   (setq Layers (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
  15.   (setq laystr "")
  16.   (vlax-for item Layers
  17.     (setq lay (vla-get-Name item))
  18.     (if (= (vla-get-Color item) col)
  19.       (if (= laystr "")
  20.         (setq laystr lay)
  21.         (setq laystr (strcat laystr "," lay))
  22.       )
  23.     )
  24.   )
  25.   (if (= laystr "")
  26.     (setq ss (ssget (list (cons 62 col))))
  27.     (setq ss
  28.       (ssget
  29.         (list
  30.           '(-4 . "<OR")
  31.               (cons 62 col)
  32.               '(-4 . "<AND")
  33.                   (cons 8 laystr)
  34.                   '(62 . 256)
  35.               '(-4 . "AND>")
  36.           '(-4 . "OR>")
  37.         )
  38.       )
  39.     )
  40.   )
  41. )
  42. ;选择与指定对象颜色相同的对象(包括随层对象，包括块对象)
  43. (defun c:GetSameColorSS ( / en ss n)
  44.   (vl-load-com)
  45.   (if (setq en (car (entsel "\n请选择源对象：")))
  46.     (setq ss (GetColorSS (GetColor en)))
  47.   )
  48.   (sssetfirst nil ss)
  49.   (if ss
  50.     (setq n (sslength ss))
  51.     (setq n 0)
  52.   )
  53.   (princ (strcat "\n选择与指定对象颜色相同的对象" (rtos n 2 4) "个。"))
  54.   (princ)
  55. )

回复 支持 反对

使用道具 举报

vectra
发表于 2018-3-15 08:53:07 | 显示全部楼层
  1. (defun c:xyc ()
  2.   (while (null (setq obj (entsel "\n请选过滤颜色对象"))))
  3.   (setq        dxf (entget (car obj))
  4.         c   (cdr (assoc 62 dxf))
  5.   )
  6.   (if (null c)                                ;如果图元颜色为随层
  7.     (setq c (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 dxf)))))) ;提取图层颜色
  8.   )
  9.   (setq        ss1 (ssget)
  10.         ss  (ssadd)
  11.   )                                        ;新建选择集
  12.   (repeat (setq xh (sslength ss1))        ;循环选择集的每一个图元
  13.     (setq dxf (entget (ssname ss1 (setq xh (1- xh))))
  14.           c2  (cdr (assoc 62 dxf))
  15.     )                                        ;图元颜色
  16.     (if        (null c2)                        ;如果图元颜色为随层
  17.       (setq c2 (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 dxf)))))) ;提取图层颜色
  18.     )
  19.     (if        (= c2 c)
  20.       (ssadd (ssname ss1 xh) ss)        ;加入到选择集
  21.     )
  22.   )
  23.   (sssetfirst nil ss)
  24.   (princ (strcat "\n已选择" (itoa (sslength ss)) "个对象"))
  25.   (princ)
  26. )
回复 支持 反对

使用道具 举报

尒樣僮
 楼主| 发表于 2018-3-15 09:42:23 | 显示全部楼层
谢谢楼上两位的帮忙  一下看不懂  的慢慢理解  
回复 支持 反对

使用道具 举报

xyp1964
发表于 2019-2-15 22:42:21 | 显示全部楼层
  1. ;; 按颜色选择
  2. (defun c:tt ()
  3.   (defun GetCo (s0 / a la co en)
  4.     (setq en (entget s0))
  5.     (if  (setq a (assoc 62 en))
  6.       (cdr a)
  7.       (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 en)))))
  8.     )
  9.   )
  10.   (if (progn  (setq s0 (car (entsel "\n请选过滤颜色对象: ")))
  11.         (redraw s0 3)
  12.         (setq ss1 (ssget))
  13.       )
  14.     (progn      (setq co (GetCo s0) ss (ssadd) i  -1)
  15.       (while (setq s1 (ssname ss1 (setq i (1+ i))))
  16.         (if (= (GetCo s1) co) (ssadd s1 ss))
  17.       )
  18.       (sssetfirst nil ss)
  19.       (princ (strcat "\n已选择" (itoa (sslength ss)) "个对象"))
  20.     )
  21.   )
  22.   (princ)
  23. )

点评

kucha007
赞  发表于 2022-11-17 22:14

评分

参与人数 1明经币 +1 收起 理由
LYC688 + 1

查看全部评分

回复 支持 反对

使用道具 举报

笑我秦兴
发表于 2020-8-13 10:53:11 | 显示全部楼层
感谢，终于找到了想要的功能
回复 支持 反对

使用道具 举报

123下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-16 02:43 , Processed in 0.185404 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表