【TB原创】自定义快速选择，简单实用，事半功倍

tengte

;【2014.04.07】发一个支持选择相同的直线(长度+角度)、多段线(长度+面积)的函数
;注：Fuzz为比较的精度。角度为弧度，本程度仅为粗略比较，各位可根据自己的要求优化。长度相同但旋转180度的直线不会被选中；长度相同但接近0度与360度的直线会被区分，此种情况易被认为程序出错。

2. (defun C:SL (/ SS New Fuzz Obj Pro Typ Len a name i n lst)
   
3.   (princ "\n〈== 选择相同的直线(长度+角度)、多段线(长度+面积) ==〉")
   
4.   (setq Fuzz 0.01)
   
5.   (sssetfirst nil nil)
   
6.   (and
   
7.     (princ "\n请选择模板对象（直线或多段线）:")
   
8.     (setq SS (ssget ":S" '((0 . "*LINE"))))
   
9.     (setq name (ssname SS 0)
   
10.     Typ  (cdr (assoc 0 (entget name)))
    
11.     lst  (list (cons 0 Typ))
    
12.     Obj  (vlax-ename->vla-object name)
    
13.     Len  (vla-get-Length Obj)
    
14.     )
    
15.     (princ "\n请选择目标对象:")
    
16.     (setq SS (ssget lst))
    
17.     (if  (= Typ "LINE")
    
18.       (setq Pro "Angle")
    
19.       (setq Pro "Area")
    
20.     ) ;if
    
21.     (setq Len (vla-get-Length Obj)
    
22.     a   (vlax-get-Property Obj Pro)
    
23.     New (ssadd)
    
24.     n   (sslength SS)
    
25.     i   0
    
26.     )
    
27.     (while (< i n)
    
28.       (setq name (ssname SS i)
    
29.       i   (1+ i)
    
30.       Obj   (vlax-ename->vla-object name)
    
31.       )
    
32.       (and
    
33.   (equal Len (vla-get-Length Obj) Fuzz)
    
34.   (equal a (vlax-get-Property Obj Pro) Fuzz)
    
35.   (setq New (ssadd name New))
    
36.       ) ;and
    
37.     ) ;while
    
38.   ) ;and
    
39.   (sssetfirst nil New)
    
40.   (princ)
    
41. ) ;defun

(defun C:SL (/ SS New Fuzz Obj Pro Typ Len a name i n lst)<br />   (princ "\n〈== 选择相同的直线(长度+角度)、多段线(长度+面积) ==〉")<br />   (setq Fuzz 0.01)<br />   (sssetfirst nil nil)<br />   (and<br />     (princ "\n请选择模板对象（直线或多段线）:")<br />     (setq SS (ssget ":S" '((0 . "*LINE"))))<br />     (setq name (ssname SS 0)<br />     Typ  (cdr (assoc 0 (entget name)))<br />     lst  (list (cons 0 Typ))<br />     Obj  (vlax-ename->vla-object name)<br />     Len  (vla-get-Length Obj)<br />     )<br />     (princ "\n请选择目标对象:")<br />     (setq SS (ssget lst))<br />     (if  (= Typ "LINE")<br />       (setq Pro "Angle")<br />       (setq Pro "Area")<br />     ) ;if<br />     (setq Len (vla-get-Length Obj)<br />     a   (vlax-get-Property Obj Pro)<br />     New (ssadd)<br />     n   (sslength SS)<br />     i   0<br />     )<br />     (while (< i n)<br />       (setq name (ssname SS i)<br />       i   (1+ i)<br />       Obj   (vlax-ename->vla-object name)<br />       )<br />       (and<br />   (equal Len (vla-get-Length Obj) Fuzz)<br />   (equal a (vlax-get-Property Obj Pro) Fuzz)<br />   (setq New (ssadd name New))<br />       ) ;and<br />     ) ;while<br />   ) ;and<br />   (sssetfirst nil New)<br />   (princ)<br /> ) ;defun

;【2013.11.09】再发一个支持动态块处理的函数
;用途：解决动态块用块名筛选的难题。
;;;接口函数：获取动态块的多个匿名块名。返回值：nil 或 "`*?*,`*?*..."
(defun TB:GetDynamicName (Block / DXF EN bl name ent lst)
  (defun DXF (code lst)
    (cdr (assoc code lst))
  ) ;defun
  (while (setq bl (tblnext "BLOCK" (null bl)))
    (and
      (= 1 (logand 1 (DXF 70 bl))) ;匿名块
      (setq name (DXF 2 bl)
     ent  (tblobjname "BLOCK" name)
     ent  (DXF 330 (entget ent))
     ent  (DXF 331 (entget ent))
      )
      (setq EN (vla-get-EffectiveName (vlax-ename->vla-object ent)))
      (wcmatch EN Block)
      (setq name (strcat "`" name))
      (not (member name lst))
      (setq lst (cons name lst))
    ) ;and
  ) ;while
  (and
    (setq lst  (reverse lst)
   name (car lst)
   lst  (cdr lst)
    )
    (setq lst  (mapcar '(lambda (e) (strcat "," e)) lst)
   name (strcat name (apply 'strcat lst))
    )
  ) ;and
  name
)

;;;接口函数：快速选择--根据选中的模板对象，过滤所需的对象。
;;; 参数说明：new--为nil时，可先选中需要过滤对象再选择模板对象（最后选中的对象不会显示夹点），
;;;                   否则，选中模板对象后，重新选择需要过滤对象；
;;;                   ids --DXF组码列表，由需与模板对象匹配的组码组成。
;;;                   关于DXF组码，可查看CAD自带的帮助文档acad_dxf.chm。
(defun TB:QS (new ids / GetPat filter)
  (defun GetPat (ids / SS en lst)
    (and
      (setq SS (entsel "\n请选择模板对象:"))
      (setq en (entget (car SS))
     lst (vl-remove-if-not '(lambda (e) (member (car e) ids)) en)
      )
    ) ;and
;;;以下黄底蓝字部分，根据luyu9635 的发现修改和完善。
;;;修改后，可实现对颜色和线型筛选，能正确区分随层的特性。
    (and
      (member 6 ids)
      (not (assoc 6 lst))
      (setq lst (cons '(6 . "ByLayer") lst)) ;线型名随层
    ) ;and
    (and
      (member 62 ids)
      (not (assoc 62 lst))
      (setq lst (cons '(62 . 256) lst)) ;颜色号随层
    ) ;and
    lst
  ) ;defun
  (and new (sssetfirst nil nil)) ;new为T时，重新选择
  (and
    (setq filter (GetPat ids))
    (sssetfirst nil (ssget filter))
  ) ;and
  (princ)
)

;;;----------------------------------------------------------------------------------------
;;;应用实例。函数名C:XX中XX可自定义，且XX为调用此函数的命令。
;;;各位可以举一反三，定义自己所需的快速选择的命令。
;;;若觉得本函数好用，请回帖支持。以后我还会发布更多实用的函数。

(defun C:Q () ;类型 图层 颜色[ 内容(文字) 块名(块) 半径/高度(圆/文字) 顶点数(多段线)]
  (TB:QS T '(0 8 62 1 2 40 90))
)
(defun C:QT () ;图元类型
  (TB:QS T '(0))
)
(defun C:QD () ;图层
  (TB:QS T '(8))
)
(defun C:QC () ;颜色
  (TB:QS T '(62))
)
(defun C:QDT () ;图元类型 线型
  (TB:QS T '(0 6))
)
(defun C:QTT () ;文字内容
  (TB:QS T '(1))
)
(defun C:QTH () ;文字高度
  (TB:QS T '(40))
)

;;; 另外，本人编写了一个去除AutoCAD教育版打印戳记的软件，感兴趣的朋友可以去本论坛的另一帖子看一看：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=78256

【2013.11.04】再发一个升级版的函数，可选择多个模板对象。增加一个mode参数，非nil时选单个对象为模板，否则可选多个对象为模板。（与21楼网友修改的功能不一样）
　　调用实例：
(defun C:QQ () ;类型 图层 颜色[ 内容(文字) 块名(块) 半径/高度(圆/文字) 顶点数(多段线)]
  (TB:QS2 T nil '(0 8 62 1 2 40 90))
)

2. ;;;接口函数：快速选择
   
3. (defun TB:QS2 (new mode ids / GetDxfs GetPat filter)
   
4.   (defun GetDxfs (name ids / Func en lst)
   
5.     (setq en   (entget name)
   
6.     Func '(lambda (e) (member (car e) ids))
   
7.     lst  (vl-remove-if-not Func en)
   
8.     )
   
9.     (and
   
10.       (member 6 ids)
    
11.       (not (assoc 6 lst))
    
12.       (setq lst (cons '(6 . "ByLayer") lst)) ;线型名随层
    
13.     ) ;and
    
14.     (and
    
15.       (member 62 ids)
    
16.       (not (assoc 62 lst))
    
17.       (setq lst (cons '(62 . 256) lst)) ;颜色号随层
    
18.     ) ;and
    
19.     lst
    
20.   ) ;defun
    
21.   (defun GetPat  (mode ids / SS i name names lst)
    
22.     (if  mode
    
23.       (and
    
24.   (setq SS (entsel "\n请选择一个模板对象:"))
    
25.   (setq names (list (car SS)))
    
26.       ) ;and/else
    
27.       (and
    
28.   (princ "\n请选择模板对象(可多选):")
    
29.   (setq SS (ssget))
    
30.   (setq i (sslength SS))
    
31.   (repeat  i
    
32.     (setq  i     (1- i)
    
33.     names (cons (ssname SS i) names)
    
34.     )
    
35.   ) ;repeat
    
36.       ) ;and
    
37.     ) ;if
    
38.     (foreach name names
    
39.       (and
    
40.   (setq itm (GetDxfs name ids))
    
41.   (or
    
42.     (> 2 (length itm))
    
43.     (setq itm (append '((-4 . "<AND")) itm '((-4 . "AND>"))))
    
44.   ) ;or
    
45.   (setq lst (append lst itm))
    
46.       ) ;and
    
47.     ) ;foreach
    
48.     (and
    
49.       (< 1 (length lst))
    
50.       (setq lst (append '((-4 . "<OR")) lst '((-4 . "OR>"))))
    
51.     ) ;and
    
52.     lst
    
53.   ) ;defun
    
54.   (and new (sssetfirst nil nil)) ;new为T时，重新选择
    
55.   (and
    
56.     (setq filter (GetPat mode ids))
    
57.     (print filter)
    
58.     (sssetfirst nil (ssget filter))
    
59.   ) ;and
    
60.   (princ)
    
61. )

;;;接口函数：快速选择<br /> (defun TB:QS2 (new mode ids / GetDxfs GetPat filter)<br />   (defun GetDxfs (name ids / Func en lst)<br />     (setq en   (entget name)<br />     Func '(lambda (e) (member (car e) ids))<br />     lst  (vl-remove-if-not Func en)<br />     )<br />     (and<br />       (member 6 ids)<br />       (not (assoc 6 lst))<br />       (setq lst (cons '(6 . "ByLayer") lst)) ;线型名随层<br />     ) ;and<br />     (and<br />       (member 62 ids)<br />       (not (assoc 62 lst))<br />       (setq lst (cons '(62 . 256) lst)) ;颜色号随层<br />     ) ;and<br />     lst<br />   ) ;defun<br />   (defun GetPat  (mode ids / SS i name names lst)<br />     (if  mode<br />       (and<br />   (setq SS (entsel "\n请选择一个模板对象:"))<br />   (setq names (list (car SS)))<br />       ) ;and/else<br />       (and<br />   (princ "\n请选择模板对象(可多选):")<br />   (setq SS (ssget))<br />   (setq i (sslength SS))<br />   (repeat  i<br />     (setq  i     (1- i)<br />     names (cons (ssname SS i) names)<br />     )<br />   ) ;repeat<br />       ) ;and<br />     ) ;if<br />     (foreach name names<br />       (and<br />   (setq itm (GetDxfs name ids))<br />   (or<br />     (> 2 (length itm))<br />     (setq itm (append '((-4 . "<AND")) itm '((-4 . "AND>"))))<br />   ) ;or<br />   (setq lst (append lst itm))<br />       ) ;and<br />     ) ;foreach<br />     (and<br />       (< 1 (length lst))<br />       (setq lst (append '((-4 . "<OR")) lst '((-4 . "OR>"))))<br />     ) ;and<br />     lst<br />   ) ;defun<br />   (and new (sssetfirst nil nil)) ;new为T时，重新选择<br />   (and<br />     (setq filter (GetPat mode ids))<br />     (print filter)<br />     (sssetfirst nil (ssget filter))<br />   ) ;and<br />   (princ)<br /> )

luyu9635

小改了一下，个人觉行这样更方便，可以选择到同图层中的同一颜色

;;快速选择
(defun QSel (new ids / GetPat filter dx62)
  (defun GetPat (ids / SS en lst)
    (and
      (setq SS (entsel "\n请选择模板对象:"))
      (setq en (entget (car SS))
     lst (vl-remove-if-not '(lambda (e) (member (car e) ids)) en)
      )
    ) ;and
     (if (member 62 ids)
                         (progn
                           (or (setq dx62 (assoc 62 en))(setq dx62 (cons '62 256)))
                           (setq lst (append lst (list dx62)))
                         )
       )
  lst

  ) ;defun
  (and new (sssetfirst nil nil)) ;new为T时，重新选择
  (and
    (setq filter (GetPat ids))
    (sssetfirst nil (ssget filter))
  ) ;and
  (princ)
)

清山小石

我记得以前有一个输入Q再选择颜色、类型等等、、那个怎么弄的？

clm840917

随层颜色不区分  我的图向来都是随层的

唐伯虎9527

感谢分享 谢谢了

li809

谢谢回复！

sxm121233

学习了，

tengte

谢谢回复！

qyming

好东西，收了

434939575

很好。学习了。感谢。

519995995

明经很好很强大，因为大家的热情和分享。顶了！