按块名过滤

KO你

原帖  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 - [lst] List of strings to concatenate
;; del - [str] 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)

hzyhzjjzh

谢谢楼主分享

白色微風1991

謝謝樓主分享