【TB原创】自定义快速选择，简单实用，事半功倍
本帖最后由 tengte 于 2014-4-7 09:26 编辑;【2014.04.07】发一个支持选择相同的直线(长度+角度)、多段线(长度+面积)的函数
;注：Fuzz为比较的精度。角度为弧度，本程度仅为粗略比较，各位可根据自己的要求优化。长度相同但旋转180度的直线不会被选中；长度相同但接近0度与360度的直线会被区分，此种情况易被认为程序出错。(defun C:SL (/ SS New Fuzz Obj Pro Typ Len a name i n lst)
(princ "\n〈== 选择相同的直线(长度+角度)、多段线(长度+面积) ==〉")
(setq Fuzz 0.01)
(sssetfirst nil nil)
(and
(princ "\n请选择模板对象（直线或多段线）:")
(setq SS (ssget ":S" '((0 . "*LINE"))))
(setq name (ssname SS 0)
Typ(cdr (assoc 0 (entget name)))
lst(list (cons 0 Typ))
Obj(vlax-ename->vla-object name)
Len(vla-get-Length Obj)
)
(princ "\n请选择目标对象:")
(setq SS (ssget lst))
(if(= Typ "LINE")
(setq Pro "Angle")
(setq Pro "Area")
) ;if
(setq Len (vla-get-Length Obj)
a (vlax-get-Property Obj Pro)
New (ssadd)
n (sslength SS)
i 0
)
(while (< i n)
(setq name (ssname SS i)
i (1+ i)
Obj (vlax-ename->vla-object name)
)
(and
(equal Len (vla-get-Length Obj) Fuzz)
(equal a (vlax-get-Property Obj Pro) Fuzz)
(setq New (ssadd name New))
) ;and
) ;while
) ;and
(sssetfirst nil New)
(princ)
) ;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))
);;;接口函数：快速选择
(defun TB:QS2 (new mode ids / GetDxfs GetPat filter)
(defun GetDxfs (name ids / Func en lst)
(setq en (entget name)
Func '(lambda (e) (member (car e) ids))
lst(vl-remove-if-not Func en)
)
(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
(defun GetPat(mode ids / SS i name names lst)
(ifmode
(and
(setq SS (entsel "\n请选择一个模板对象:"))
(setq names (list (car SS)))
) ;and/else
(and
(princ "\n请选择模板对象(可多选):")
(setq SS (ssget))
(setq i (sslength SS))
(repeati
(setqi (1- i)
names (cons (ssname SS i) names)
)
) ;repeat
) ;and
) ;if
(foreach name names
(and
(setq itm (GetDxfs name ids))
(or
(> 2 (length itm))
(setq itm (append '((-4 . "<AND")) itm '((-4 . "AND>"))))
) ;or
(setq lst (append lst itm))
) ;and
) ;foreach
(and
(< 1 (length lst))
(setq lst (append '((-4 . "<OR")) lst '((-4 . "OR>"))))
) ;and
lst
) ;defun
(and new (sssetfirst nil nil)) ;new为T时，重新选择
(and
(setq filter (GetPat mode ids))
(print filter)
(sssetfirst nil (ssget filter))
) ;and
(princ)
) 小改了一下，个人觉行这样更方便，可以选择到同图层中的同一颜色
;;快速选择
(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再选择颜色、类型等等、、那个怎么弄的？ 随层颜色不区分我的图向来都是随层的 感谢分享 谢谢了 谢谢回复！ 学习了， 谢谢回复！ 好东西，收了 很好。学习了。感谢。 明经很好很强大，因为大家的热情和分享。顶了！