社区 › Auto Lisp › 用chan重新定义块

fixo 发表于 2022-7-6 12:46:43

 
对不起，我正在睡觉(
c u明天
 
~'J'~

fixo 发表于 2022-7-6 12:48:57

 
啊，睡不着
 
尝试
 

(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 (strcase
             (vl-string-translate
             (chr 32)
             (chr 95)
             (vla-get-promptstring att))) prompts)
             )
       (vla-put-tagstring
           att
           (strcase
             (vl-string-translate
             (chr 32)
             (chr 95)
             (vla-get-promptstring att)))))
)
)

   (setq prompts (reverse prompts))

   (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-delete blk)
               (vlax-release-object blk)
        (vla-put-layer new_block layer)
        (setq ats (vlax-invoke new_block 'Getattributes))
        (foreach atats
          (if (setq find (assoc (vla-get-tagstring at) block_info))
          (vla-put-textstring at (cdr find)))
          (vla-update at)
          )
          )
        )
      )
    )
)
)
   )
   )
(princ)
)


(defun C:CTP(/)
(change-tags-by-prompts)
(princ)
)


(vl-load-com)
(princ "\n   ***   Type CTP to execute   **")
(prin1)

 
~'J'~

Lee Mac 发表于 2022-7-6 12:55:05

 
哈哈，你让我想起了我

rarmstrong 发表于 2022-7-6 12:56:55

：）非常感谢fixo。。。。它就像一种魅力。。。。。我太感谢你了。。。。祝你过得愉快！！！！！

fixo 发表于 2022-7-6 13:02:09

 
不客气
很乐意帮忙
 
~'J'~

查看完整版本: 用chan重新定义块