明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 15064|回复: 57

[源码] 【TB原创】自定义快速选择,简单实用,事半功倍

  [复制链接]
发表于 2013-8-20 22:10 | 显示全部楼层 |阅读模式
本帖最后由 tengte 于 2014-4-7 09:26 编辑

;【2014.04.07】发一个支持选择相同的直线(长度+角度)、多段线(长度+面积)的函数
;注:Fuzz为比较的精度。角度为弧度,本程度仅为粗略比较,各位可根据自己的要求优化。长度相同但旋转180度的直线不会被选中;长度相同但接近0度与360度的直线会被区分,此种情况易被认为程序出错。
  1. (defun C:SL (/ SS New Fuzz Obj Pro Typ Len a name i n lst)
  2.   (princ "\n〈== 选择相同的直线(长度+角度)、多段线(长度+面积) ==〉")
  3.   (setq Fuzz 0.01)
  4.   (sssetfirst nil nil)
  5.   (and
  6.     (princ "\n请选择模板对象(直线或多段线):")
  7.     (setq SS (ssget ":S" '((0 . "*LINE"))))
  8.     (setq name (ssname SS 0)
  9.     Typ  (cdr (assoc 0 (entget name)))
  10.     lst  (list (cons 0 Typ))
  11.     Obj  (vlax-ename->vla-object name)
  12.     Len  (vla-get-Length Obj)
  13.     )
  14.     (princ "\n请选择目标对象:")
  15.     (setq SS (ssget lst))
  16.     (if  (= Typ "LINE")
  17.       (setq Pro "Angle")
  18.       (setq Pro "Area")
  19.     ) ;if
  20.     (setq Len (vla-get-Length Obj)
  21.     a   (vlax-get-Property Obj Pro)
  22.     New (ssadd)
  23.     n   (sslength SS)
  24.     i   0
  25.     )
  26.     (while (< i n)
  27.       (setq name (ssname SS i)
  28.       i   (1+ i)
  29.       Obj   (vlax-ename->vla-object name)
  30.       )
  31.       (and
  32.   (equal Len (vla-get-Length Obj) Fuzz)
  33.   (equal a (vlax-get-Property Obj Pro) Fuzz)
  34.   (setq New (ssadd name New))
  35.       ) ;and
  36.     ) ;while
  37.   ) ;and
  38.   (sssetfirst nil New)
  39.   (princ)
  40. ) ;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))
)
  1. ;;;接口函数:快速选择
  2. (defun TB:QS2 (new mode ids / GetDxfs GetPat filter)
  3.   (defun GetDxfs (name ids / Func en lst)
  4.     (setq en   (entget name)
  5.     Func '(lambda (e) (member (car e) ids))
  6.     lst  (vl-remove-if-not Func en)
  7.     )
  8.     (and
  9.       (member 6 ids)
  10.       (not (assoc 6 lst))
  11.       (setq lst (cons '(6 . "ByLayer") lst)) ;线型名随层
  12.     ) ;and
  13.     (and
  14.       (member 62 ids)
  15.       (not (assoc 62 lst))
  16.       (setq lst (cons '(62 . 256) lst)) ;颜色号随层
  17.     ) ;and
  18.     lst
  19.   ) ;defun
  20.   (defun GetPat  (mode ids / SS i name names lst)
  21.     (if  mode
  22.       (and
  23.   (setq SS (entsel "\n请选择一个模板对象:"))
  24.   (setq names (list (car SS)))
  25.       ) ;and/else
  26.       (and
  27.   (princ "\n请选择模板对象(可多选):")
  28.   (setq SS (ssget))
  29.   (setq i (sslength SS))
  30.   (repeat  i
  31.     (setq  i     (1- i)
  32.     names (cons (ssname SS i) names)
  33.     )
  34.   ) ;repeat
  35.       ) ;and
  36.     ) ;if
  37.     (foreach name names
  38.       (and
  39.   (setq itm (GetDxfs name ids))
  40.   (or
  41.     (> 2 (length itm))
  42.     (setq itm (append '((-4 . "<AND")) itm '((-4 . "AND>"))))
  43.   ) ;or
  44.   (setq lst (append lst itm))
  45.       ) ;and
  46.     ) ;foreach
  47.     (and
  48.       (< 1 (length lst))
  49.       (setq lst (append '((-4 . "<OR")) lst '((-4 . "OR>"))))
  50.     ) ;and
  51.     lst
  52.   ) ;defun
  53.   (and new (sssetfirst nil nil)) ;new为T时,重新选择
  54.   (and
  55.     (setq filter (GetPat mode ids))
  56.     (print filter)
  57.     (sssetfirst nil (ssget filter))
  58.   ) ;and
  59.   (princ)
  60. )

评分

参与人数 1明经币 +2 收起 理由
pzweng + 2 很给力!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

发表于 2013-10-28 16:25 | 显示全部楼层
小改了一下,个人觉行这样更方便,可以选择到同图层中的同一颜色

;;快速选择
(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)
)
回复 支持 1 反对 0

使用道具 举报

发表于 2017-9-18 17:51 | 显示全部楼层
我记得以前有一个输入Q再选择颜色、类型等等、、那个怎么弄的?
发表于 2021-8-26 23:52 | 显示全部楼层
随层颜色不区分  我的图向来都是随层的
发表于 2017-11-16 13:55 | 显示全部楼层
感谢分享 谢谢了
发表于 2015-1-28 12:52 | 显示全部楼层
学习了,
 楼主| 发表于 2015-1-27 09:48 | 显示全部楼层
谢谢回复!
发表于 2014-7-7 21:38 来自手机 | 显示全部楼层
好东西,收了
发表于 2014-5-13 15:48 | 显示全部楼层
很好。学习了。感谢。
发表于 2014-4-23 19:32 来自手机 | 显示全部楼层
明经很好很强大,因为大家的热情和分享。顶了!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 07:59 , Processed in 0.312982 second(s), 39 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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