[编程交流] AUTOLISP按TAG1 Va查找块

(defun c:test ( / oldtag1 obj bname newstr)
(setq oldtag1 "TAG1") ; attribute tag name
(setq obj (vlax-ename->vla-object (car (entsel "\nPick object"))))
(setq bname (vla-get-name obj)) ; block name need a check for picked a block
(setq ss (ssget "x"  (list (cons 0  "INSERT") (cons 2 bname))))
(princ "\n")
(setq newstr (getstring "Please enter new value"))
(setq x (sslength ss))
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS (setq x (- x 1)) )) 'getattributes)
(if (= oldtag1 (strcase (vla-get-tagstring att)))
(vla-put-textstring att newstr) 
) ; end if
) ; foreach
)

(defun c:doit ( / bln des ent enx flg fnd idx new sel tag )
   (setq
       bln "VIFCD_001"
       tag "DESC"
   )
   (if (setq sel (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 bln))))
       (progn
           (setq fnd (strcase (getstring t "\nSpecify attribute value to find: "))
                 new (cons  1 (getstring t (strcat "\nSpecify new value for "" tag "" attribute: ")))
           )
           (repeat (setq idx (sslength sel))
               (setq ent (entnext (ssname sel (setq idx (1- idx))))
                     enx (entget ent)
                     des nil
                     flg nil
               )
               (while (= "ATTRIB" (cdr (assoc 0 enx)))
                   (cond
                       (   (= tag (strcase (cdr (assoc 2 enx))))
                           (setq des enx)
                       )
                       (   (or flg (setq flg (wcmatch (strcase (cdr (assoc 1 enx))) fnd))))
                   )
                   (setq ent (entnext ent)
                         enx (entget  ent)
                   )
               )
               (if (and des flg)
                   (if (entmod (subst new (assoc 1 des) des))
                       (entupd (cdr (assoc -1 des)))
                   )
               )
           )
       )
       (princ (strcat "\nNo blocks called "" bln "" found in the active drawing."))
   )
   (princ)
)

(while (and (= "ATTRIB" (cdr (assoc 0 enx))) (not flg) )
 ...
); while

(defun C:test ( / bnm tag n SS fnd new i o L )
 
 (setq
   bnm "VIFCD_001"
   tag "DESC"
 )
 
 (and
   (setq n (_AttdefPosition bnm tag))
   (setq SS (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 (strcat "`**," bnm)))))
   (setq fnd (strcase (getstring t "\nSpecify attribute value to find: ")))
   (setq new (getstring t (strcat "\nSpecify new value for "" tag "" attribute: ")))
   (repeat (setq i (sslength SS))
     (and 
       (eq bnm (vla-get-EffectiveName (setq o (vlax-ename->vla-object (ssname SS (setq i (1- i)))))))
       (setq L (vlax-invoke o 'GetAttributes))
       (vl-some (function (lambda (x) (wcmatch (strcase (vla-get-TextString x)) fnd))) L)
       (vla-put-TextString (nth n L) new)
     )
   )
 )
 (princ)
); defun C:test
(defun _AttdefPosition ( bnm tgnm / e i enx f )
 (and
   (setq e (tblobjname "BLOCK" bnm))
   (setq e (cdr (assoc -2 (entget e))))
   (setq i -1)
   (while (and e (not f))
     (setq enx (entget e)) (setq e (entnext e))
     (and (member '(0 . "ATTDEF") enx) (setq i (1+ i)))
     (setq f (member (cons 2 tgnm) enx))
     (and (member '(0 . "SEQEND") enx) (setq e nil))
   )
 )
 (if f i)
); defun _AttdefPosition

(defun c:doit ( / bln dsc flg fnd idx new sel tag )
   (setq
       bln "VIFCD_001"
       tag "DESC"
   )
   (if (setq sel (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 bln))))
       (progn
           (setq fnd (strcase (getstring t "\nSpecify attribute value to find: "))
                 new (getstring t (strcat "\nSpecify new value for "" tag "" attribute: "))
           )
           (repeat (setq idx (sslength sel))
               (if (vl-some
                      '(lambda ( att )
                           (or flg (setq flg (wcmatch (strcase (vla-get-textstring att)) fnd)))
                           (or dsc (if (= tag (strcase (vla-get-tagstring att))) (setq dsc att)))
                           (and flg dsc)
                       )
                       (vlax-invoke (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) 'getattributes)
                   )
                   (vla-put-textstring dsc new)
               )
               (setq flg nil dsc nil)
           )
       )
       (princ (strcat "\nNo blocks called "" bln "" found in the active drawing."))
   )
   (princ)
)
(vl-load-com) (princ)

(setq elephant (cow->elephant (sheep->cow (dog->sheep (cat->dog (mouse->cat (fly->mouse fly)))))))

'(lambda ( att )
 (or flg (setq flg (wcmatch (strcase (vla-get-textstring att)) fnd)))
 (or dsc (if (= tag (strcase (vla-get-tagstring att))) (setq dsc att)))
 (and flg dsc)
)