按块名过滤
本帖最后由 KO你 于 2023-4-16 00:22 编辑原帖http://bbs.mjtd.com/forum.php?mo ... hlight=%B9%FD%C2%CB
原帖 http://bbs.mjtd.com/forum.php?mo ... hlight=%B9%FD%C2%CB
请路过的高手修改成支持（动态块、无名块、普通块）通用点，造福大家使用
原码以下
快捷键fg按块名过滤
(defun c:fg(/ block_name filtn ssf ent name_lst)
(princ "\n可多选取过滤---支持动态块、无名块、普通块")
(if (and
(setq ss (ssget '((0 . "INSERT"))))
(setq ss_lst
(vl-remove-if-not
'(lambda(x)
(if(and
(setq obj (vlax-ename->vla-object x))
(= (vla-get-objectname obj) "AcDbBlockReference")
(= (vla-get-isdynamicblock obj) :vlax-true))T nil))
(ss-enlst ss))))
(progn
(foreach x ss_lst (redraw x 3))
(setq name_lst
(mapcar
'(lambda(ename)
(princ"\n请框选对象范围<按空格或右键全选>:")
(if (vlax-property-available-p (setq obj(vlax-ename->vla-object ename)) 'effectivename)
(setq block_name (vla-get-effectivename obj))
(setq block_name (vla-get-name obj))))ss_lst))
(setq name_lst (LM:lst->str (LST-ONLY name_lst) ","))
(if name_lst
(progn
(Princ name_lst)
(setq filtn (list '(0 . "INSERT") (cons 2 (getublkname name_lst))))
(if (setq ssf (ssget filtn))
(princ)
(setq ssf (ssget "x" filtn)))
(if ssf
(progn
(foreach x ss_lst (redraw x 4))
(princ (sslength ssf))
(sssetfirst ssf ssf))))))
(princ "\n错误提示----请按提示选择块"))
(princ))
;; List to String-Lee Mac
;; Concatenates each string in a supplied list, separated by a given delimiter
;; lst - List of strings to concatenate
;; del - Delimiter string to separate each item
;(LM:lst->str '("1" "2" "3" "4" "5") ",")
;"1,2,3,4,5"
(defun LM:lst->str ( lst del / str )
(setq str (car lst))
(foreach itm (cdr lst) (setq str (strcat str del itm)))str)
;;表元素唯一
(defun LST-ONLY(Lst / temp)
(setq temp '())
(foreach x Lst
(if (not(member x temp))
(setq temp(cons x temp))))
(setq temp (reverse temp)))
;选择集与对象名表互转
(defun ss-enlst(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS))))
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss)))))
(defun Getublksset (/ acadobj doc ass ssetobj gpcode datavalue)
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))
(vl-Catch-All-Apply
'(lambda ()
(vla-delete (vla-item (vla-get-SelectionSets doc) "*UBSET*"))))
(setq ssetObj (vla-Add (vla-get-SelectionSets doc) "*UBSET*"))
(setq gpCode (vlax-make-safearray vlax-vbInteger '(0 . 0)))
(vlax-safearray-put-element gpCode 0 2)
(setq dataValue (vlax-make-safearray vlax-vbVariant '(0 . 0)))
(vlax-safearray-put-element dataValue 0 "`*U*")
(vla-Select ssetObj acSelectionSetAll nil nil gpCode dataValue)ssetObj)
(defun Getublkname (name / namejoin)
(setq namejoin "")
(vlax-for obj(getublksset)
(if (and
(wcmatch (strcase (vla-get-effectivename obj))
(strcase name)))
(setq namejoin (strcat ",`" (vla-get-name obj) namejoin))))
(strcat name namejoin))
(defun SSgetdynblk (name mode / names filtn)
(setq filtn (getublkname name))
(if (wcmatch (strcase mode t) "x,a,:e,:s,:e:s,:s:e,l,p")
(ssget mode (list '(0 . "insert") (cons 2 filtn)))
(ssget (list '(0 . "insert") (cons 2 filtn)))))
(prin1)
谢谢楼主分享{:1_1:} 謝謝樓主分享 本帖最后由 KO你 于 2025-6-15 04:29 编辑
以下支持普通块，属性块，动态块等。支持多选。
快捷键fgb按块名过滤
(defun c:fgb (/ ss blkNames ssAll resultSet)
(vl-load-com)
(princ "\n可多选取过滤---块名")
(if (setq ss (ssget '((0 . "INSERT"))))
(progn
(setq blkNames
(mapcar
'(lambda (e)
(vla-get-effectivename (vlax-ename->vla-object e)))
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
(setq blkNames (unique blkNames))
(prompt
(strcat "\n已选择 " (itoa (length blkNames)) " 种块、块名分别为： "
(apply 'strcat
(mapcar '(lambda (x) (strcat x ", ")) blkNames))))
(princ "\n请框选对象范围<按空格或右键全选>:")
(setq ssAll (ssget (list '(0 . "INSERT"))))
(or ssAll (setq ssAll (ssget "_X" '((0 . "INSERT")))))
(if ssAll
(progn
(setq resultSet (ssadd))
(vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
(if (member (vla-get-effectivename e) blkNames)
(ssadd (vlax-vla-object->ename e) resultSet)))
(cond
((> (sslength resultSet) 0)
(sssetfirst nil resultSet)
(prompt (strcat "\n找到 " (itoa (sslength resultSet)) " 个匹配的块参照")))
(T (prompt "\n未找到匹配的块参照！"))))
(prompt "\n图形中没有块参照！")))
(prompt "\n未选择块，操作取消"))
(princ))
(defun unique (lst)
(if lst
(cons (car lst)
(unique (vl-remove (car lst) (cdr lst)))))) 如何增加“按属性”过滤
页:
[1]