[编程交流] 用chan重新定义块

(defun c:BlkRep (/ *error* nlk doc spc blk i ss uflag ent nObj aLst att tag)
 (vl-load-com)
 (setq nblk "C:\\...dwg")   ;; Filepath of New Block to Insert
 (defun *error* (msg)
   (and uFlag (vla-EndUndoMark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))   
 (setq doc (vla-get-ActiveDocument
             (vlax-get-Acad-Object))
       
       spc (if (zerop (vla-get-activespace doc))              
             (if (= (vla-get-mspace doc) :vlax-true)
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc)))
 
 (while
   (progn
     (setq blk (getstring t "\nSpecify Block Name to Replace: "))
     (cond (  (eq "" blk) nil)
           (  (not (setq i -1 ss (ssget "_X" (list '(0 . "INSERT") (cons 2 blk)))))
              (princ "\n** Block not Found in Drawing **")))))
 (if ss
   (progn
     (setq uflag (not (vla-StartUndomark doc)))
     
     (while (setq ent (ssname ss (setq i (1+ i))))
       (setq nObj
         (vla-Insertblock spc
           (vla-get-InsertionPoint
             (setq Obj (vlax-ename->vla-object ent))) nblk
           (vla-get-Xscalefactor obj)
             (vla-get-yScalefactor obj)
               (vla-get-zscalefactor obj)
                 (vla-get-Rotation obj)))
       (setq aLst
         (mapcar
           (function
             (lambda (x)
               (cons (strcase (vla-get-TagString x)) (vla-get-TextString x))))
           (vlax-invoke Obj 'GetAttributes)))
       (foreach att (vlax-invoke nObj 'GetAttributes)
         (if (setq tag (assoc (strcase (vla-get-TagString att)) aLst))
           (vla-put-TextString att (cdr tag))))
       (entdel ent))
     (setq uflag (vla-EndUndoMark doc))))
 (princ))
 

(defun C:CTP(/)
(defun change-tags-by-prompts (/ adoc att bname ent find obj prompts)
 (setq        adoc (vla-get-activedocument
       (vlax-get-acad-object)
     )
 )
 (setq prompts '("REV 1 DRAWN BY"
          "REV 1 DATE")
)
 (setq ent (car (entsel "\n        ***        Select block to change tags: ")))
 (if ent
   (progn
     (setq obj (vlax-ename->vla-object ent))
     (if (eq :vlax-false (vla-get-isdynamicblock obj))
     (setq bname (vla-get-name obj))
(setq bname (vla-get-effectivename obj))
)
     (vlax-for        att (vla-item (vla-get-blocks adoc) bname)
(if (eq (vla-get-objectname att) "AcDbAttributeDefinition")
  (if (setq find (member (vla-get-promptstring att) prompts))
      (vla-put-tagstring att (strcase (car find)))
    )
)
     )
     (setvar "cmdecho" 0)
     (command "._attsync" "_N" bname)
     (setvar "cmdecho" 1)
     (vlax-release-object obj)
   )
 )
 (princ)
)
(change-tags-by-prompts)
(princ)
)
 (vl-load-com)
(princ "\n   ***   Type CTP to execute   **")
(prin1)

(defun change-tags-by-prompts (/ acsp adoc att atts att_info blockname
                        block_info bname cur_lst ent find ipt layer
                        new_block obj prompts rot xscale yscale zscale)
 (setq        adoc (vla-get-activedocument
       (vlax-get-acad-object)
       )
acsp (vla-get-block
       (vla-get-activelayout adoc)
       )
)
 (setq ent (car (entsel "\n        ***        Select block to change tags tags: ")))
 (if ent
   (progn
     (setq obj (vlax-ename->vla-object ent))
     (if (eq :vlax-false (vla-get-isdynamicblock obj))
(setq bname (vla-get-name obj))
(setq bname (vla-get-effectivename obj))
)
     (vlax-for        att  (vla-item (vla-get-blocks adoc) bname)
(if (eq (vla-get-objectname att) "AcDbAttributeDefinition")
  (progn (setq prompts (cons (vla-get-promptstring att) prompts))
    (vla-put-tagstring att (strcase (vla-get-promptstring att)))
  )
  )
)
     (setq prompts (reverse prompts))
     (vlax-release-object obj)
     (vlax-for        layout        (vla-get-layouts adoc)
(vlax-for blk  (vla-get-block layout)
  (if (eq (vla-get-objectname blk) "AcDbBlockReference")
    (progn
    (if        (eq :vlax-false (vla-get-isdynamicblock blk))
      (setq blockname (vla-get-name blk))
      (setq blockname (vla-get-effectivename blk))
      )
    (if        (eq bname blockname)
      (progn
        (setq block_info nil)
        (setq ipt    (vla-get-insertionpoint blk)
              layer  (vla-get-layer blk)
              rot    (vla-get-rotation blk)
              xscale (vla-get-xscalefactor blk)
              yscale (vla-get-yscalefactor blk)
              zscale (vla-get-zscalefactor blk)
              )
        (foreach att  (vlax-invoke blk 'Getattributes)
          (setq        att_info (cons (car prompts)
                               (vla-get-textstring att)
                               )
                )
          (setq prompts (cdr prompts))
          (setq block_info (cons att_info block_info))
          )
        (setq block_info (reverse block_info))
        (setq new_block (vla-insertblock acsp ipt bname xscale yscale zscale rot))
        (vla-put-layer new_block layer)
        (setq atts (vlax-invoke new_block 'Getattributes))
        (foreach att  atts
          (if (setq find (assoc (vla-get-tagstring att) block_info))
            (vla-put-textstring att (cdr find)))
            )
          )
        )
      )
    )
  )
)
     )
   )
 (princ)
 )
(defun C:CTP(/)
(change-tags-by-prompts)
(princ) 
)
(vl-load-com)
(princ "\n   ***   Type CTP to execute   **")
(prin1)