;; Selection of block references according to attribute labels and their specific values
;; Saved from:
;; http://cadxp.com/index.php?/topic/37573-faire-une-selection-dun-bloc-en-fonction-de-deux-de-ses-attributs/page__pid__207342#entry207342
;;
;; Routine by VDH-Bruno le: 28/05/2013
;; ======================================================================

(defun c:fa (/ lstTagAtt tagAtt doc ss1 ss2 inclu-p inputval)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
ss2 (ssadd)
)

(vlax-for b (vla-get-Blocks doc)
(if (and (= (vla-get-IsLayout B) :vlax-false)
(= (vla-get-IsXref B) :vlax-false)
(not (wcmatch (vla-get-Name B) "*|*"))
)
(vlax-for o b
(and (= (vla-get-ObjectName o) "AcDbAttributeDefinition")
(not (member (setq tagAtt (vla-get-TagString o)) lstTagAtt))
(setq lstTagAtt (cons tagAtt lstTagAtt))
)
)
)
)

(setq
lstTagAtt (listbox

"Attribute Fields/Columns "
"Select the Attribute Fields/Columns to Filter ... "

(mapcar 'cons (setq lstTagAtt (vl-sort lstTagAtt '<)) lstTagAtt)
2
)
)

(defun inputval (l)
(if l
(cons
(cons
(car l)

(getstring (strcat "Value to search for the Fields/Columns " (car l) ": ")

)
)
(inputval (cdr l))
)
)
)

(cond
((setq lstTagAtt (inputval lstTagAtt))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(princ "\nSelect the Blocks or : " )

(or (ssget (list '(0 . "INSERT") '(66 . 1)))
(ssget "_X" (list '(0 . "INSERT") '(66 . 1)))
)

(defun inclu-p (l1 l2)
(cond ((null l1) t)
((member (car l1) l2) (inclu-p (cdr l1) l2))
(t nil)
)
)

(vlax-for b (setq ss1 (vla-get-ActiveSelectionSet doc))
;; vיrifie que les critטres de filtres liste (Tag .Val) sont compris dans le bloc
(if (inclu-p
lstTagAtt
;; Liste les couples (Tag .Val) de la rיfיrence de bloc
(mapcar
'(lambda (x) (cons (vla-get-TagString x) (vla-get-TextString x)))
(vlax-invoke b 'GetAttributes)
)
)
(ssadd (vlax-vla-object->ename B) ss2)
)
)
(vla-delete ss1)
(sssetfirst nil ss2)
)
)
(princ)
)

(defun str2lst (str sep / pos)
(if (setq pos (vl-string-search sep str))
(cons (substr str 1 pos)
(str2lst (substr str (+ (strlen sep) pos 1)) sep)
)
(list str)
)
)

;

(defun ListBox (title msg keylab flag / tmp file dcl_id choice)
(setq tmp (vl-filename-mktemp "tmp.dcl")
file (open tmp "w")
)
(write-line
(strcat "ListBox:dialog{label=\"" title "\";")
file
)
(if (and msg (/= msg ""))
(write-line (strcat ":text{label=\"" msg "\";}") file)
)
(write-line
(cond
((= 0 flag) "spacer;:popup_list{key=\"lst\";")
((= 1 flag) "spacer;:list_box{key=\"lst\";")
(T "spacer;:list_box{key=\"lst\";multiple_select=true;")
)
file
)
(write-line "}spacer;ok_cancel;}" file)
(close file)
(setq dcl_id (load_dialog tmp))
(if (not (new_dialog "ListBox" dcl_id))
(exit)
)
(start_list "lst")
(mapcar 'add_list (mapcar 'cdr keylab))
(end_list)
(action_tile
"accept"
"(or (= (get_tile \"lst\") \"\")
(if (= 2 flag) (progn
(foreach n (str2lst (get_tile \"lst\") \" \")
(setq choice (cons (nth (atoi n) (mapcar 'car keylab)) choice)))
(setq choice (reverse choice)))
(setq choice (nth (atoi (get_tile \"lst\")) (mapcar 'car keylab)))))
(done_dialog)"
)
(start_dialog)
(unload_dialog dcl_id)
(vl-file-delete tmp)
choice
)

(c:fa)

Advertisements