[编程交流] 更改块的属性标记

(defun c:attupd (/ ss sel doc lst tag)
 (vl-load-com)
 (if (setq ss (ssget "_X" '((0 . "INSERT") (66 . 1))))
   (progn
     (vlax-for Obj (setq sel (vla-get-ActiveSelectionSet
                               (setq doc (vla-get-ActiveDocument
                                           (vlax-get-acad-object)))))
       (vlax-for Sub (vla-item
                       (vla-get-Blocks doc)
                         (vla-get-Name Obj))
         (if (eq "AcDbAttributeDefinition"
               (vla-get-ObjectName Sub))
           (setq lst
             (cons
               (cons
                 (vla-get-TagString Sub)
                   (vl-list->string
                     (subst 95 32
                       (vl-string->list
                         (vla-get-PromptString Sub))))) lst))))
       (foreach att (vlax-invoke Obj 'GetAttributes)
         (if (setq tag (assoc (vla-get-TagString att) lst))
           (vla-put-TagString att (cdr tag))))
       (setq lst nil))
     (vla-delete sel))
   (princ "\n** No Attributed Blocks Found **"))
 (princ))

(defun c:attr_rename_list (  / x_en enn edd ss slen ix atnam 
          namelist hit blk_ent
          matchname newed x) 
 ; Process all block instances on active drawing. Check each 
 ; attribute for match on first element in list below. On any
 ; match, rename the attribute to the new name given in the
 ; second element. 
 ; ***********   ATTRIBUTE OLD versus NEW names list   ******************
 (setq namelist (list
     ; list old name and new name. Old name can contain wild cards.
     (list "OLD_TAG_NAME#1" "NEW_TAG_NAME#1")  ; list old name and new name. 
     (list "OLD_TAG_NAME#2" "NEW_TAG_NAME#2")
     (list "OLD_TAG_NAME#3" "NEW_TAG_NAME#3")
     (list "OLD_TAG_NAME#4" "NEW_TAG_NAME#4")
     (list "OLD_TAG_NAME#5" "NEW_TAG_NAME#5")
 ) )  
 ; **********************************************************************
 ; Extract selection set of all block inserts on active drawing  
 (setq ss (ssget "_X" '((0 . "INSERT"))))
 (if (/= ss nil)
   (progn
     (setq slen (sslength ss))
     (setq ix 0)
     (while (< ix slen)
       (setq blk_ent (ssname ss ix)) ; get next block insert to process        
       (setq ix (1+ ix)) ; increment for next time
       (setq enn (entnext blk_ent)) 
       (setq edd (entget enn))  
       (while (AND enn (/= (cdr (assoc 0 edd)) "SEQEND") 
                           (/= (cdr (assoc 0 edd)) "INSERT") )
         (if (= (cdr (assoc 0 edd)) "ATTRIB")
           (progn
             (setq atnam (cdr (assoc 2 edd)))
             (setq hit nil)
             (foreach x namelist
               (if (not hit)
                 (progn ; no match yet, keep processing
                   (setq matchname (car x))                
                   (if (wcmatch atnam matchname) 
                     (progn ; found exact match or wild-card match
                       ; Change name now. Substitute in new name.
                       (setq newed (subst (cons 2 (cadr x)) (assoc 2 edd) edd)) 
                       (entmod newed) ; update the title block instance
                       (entupd blk_ent) 
                       (princ "\n")
                       (princ atnam)
                       (princ " --> ")
                       (princ (cadr x))
                       (setq hit 1) ; flag that found
               ) ) ) )
             )
           )
         )     
         ; go to next sub ent in block instance and loop back up
         (if (setq enn (entnext enn)) (setq edd (entget enn))) 
     ) ) 
     (setq ss nil) ; release the selection set
   )
 )
 (princ) ; prettier
)

defun changeblock (/ BLK DOC I TAGLST SS)
 (vl-load-com)
 (setq blk "OLDNAMEOFBLOCK"
   tagLst '(
        ;"Old Tag"    "New Tag"
 ("OLDTAG"            "NEWTAG")
        )
   i -1
   doc (vla-get-activedocument (vlax-get-acad-object))
   )
 (if (ssget "_X" (list (cons 0 "INSERT")(cons 2 blk)))
   (vlax-for bl (setq ss (vla-get-activeselectionset doc))
     (foreach att (vlax-invoke bl 'getAttributes)
   (If (assoc (vla-get-tagstring att) tagLst)
     (vla-put-tagstring att (cadr (assoc (vla-get-tagstring att) tagLst)))
     )))
   (princ "\nNo part rule Found."))
 (princ)
 (progn
   (if (tblsearch "BLOCK" "OLDNAMEOFBLOCK")
  (progn
         (command "-rename" "b" "OLDNAMEOFBLOCK" "NEWNAMEOFBLOCK")
         (command "_.-insert" "NEWNAMEOFBLOCK=FILENAME" "y" nil);replaced convert template to new template.
(command "_.attsync" "n" "NEWNAMEOFBLOCK")
(scl 0.8 "NEWNAMEOFBLOCK");scales block to new scale
  (blknr13 "NEWNAMEOFBLOCK"); this was command to set a block the a layer. (not included can eb removed)
))                  
 )(princ)(princ "succes!")(princ)
 )
;; Run program manually with this:
(defun c:Chblock () (changeblock))
;;itemline
;; Scale the old template to new one
(defun scl (xsc blk / ss)
 (vl-load-com)
 (if (setq SS (ssget "_X" (list '(0 . "INSERT") (cons 2 blk))))
   (mapcar
     (function
       (lambda (Obj)
         (vla-ScaleEntity Obj
           (vla-get-insertionpoint Obj)xsc)))
     (mapcar 'vlax-ename->vla-object
       (vl-remove-if 'listp
         (mapcar 'cadr (ssnamex ss))))))
 (princ))
;;;;;delete;;;;;
;;/delete
(defun delblk (blk / ss)
   (vl-load-com)
     (if (tblsearch "BLOCK" blk)
  (progn
(if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 blk))))
  (mapcar    'vla-delete
   (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
)
        (command "erase" ss "")
)
(command ".purge" "b" blk "n")
)
)
)

 (if  (and (eq TAG NAME)(member  TEXTSRING  '("Name1" "Name2" ...))) (then do this))

(defun c:RepEng  (/  Otag Eng NTag BLocks i Attval Found)
(vl-load-com)
(setq Otag  "NAME"
     Eng "DENNIS (BSL)"
     Ntag "DESIGN_ENG")
(if 
(setq Blocks (ssget "_X" '((0 . "INSERT")(66 . 1))))
(repeat (setq i (sslength Blocks))
     (setq AttVal
                (mapcar (function
                              (lambda (at)
                                    (list (vla-get-tagstring at)
                                          (vla-get-textstring at)
                                          at)
                                    ))
                        (vlax-invoke
                              (vlax-ename->vla-object
                                    (ssname Blocks (setq i (1- i))))
                              'Getattributes)
                        )
           )
     (if (setq Found
                    (Car (vl-remove-if-not
                               '(lambda (x)
                                      (and (eq (car x) Otag)
                                           (eq (strcase
                                                     (cadr x))
                                               Eng)))
                               AttVal)))
           (vla-put-tagstring (last Found) Ntag)
           )
     )
)
     (princ)
             )

[b][color=blue](defun c:RepEng  (/  Otag Eng NTag BLocks i Attval Found)
(vl-load-com)
(setq Otag  "NAME"
     Eng "DENNIS (BSL)"
     NEng "Daniel" )
(if 
(setq Blocks (ssget "_X" '((0 . "INSERT")(66 . 1))))
(repeat (setq i (sslength Blocks))
     (setq AttVal
                (mapcar (function
                              (lambda (at)
                                    (list (vla-get-tagstring at)
                                          (vla-get-textstring at)
                                          at)
                                    ))
                        (vlax-invoke
                              (vlax-ename->vla-object
                                    (ssname Blocks (setq i (1- i))))
                              'Getattributes)
                        )
           )
     (if (setq Found
                    (Car (vl-remove-if-not
                               '(lambda (x)
                                      (and (eq (car x) Otag)
                                           (eq (strcase
                                                     (cadr x))
                                               Eng)))
                               AttVal)))
                  (vla-put-textstring (last Found) NEng)
           )
     )
)
     (princ)
             )[/color][/b]