社区 › AutoLISP/Visual LISP 编程技术 › 多个同名块修改其中一个同名块后执行attsync不变形

dcl1214 发表于 2025-1-1 15:09:08

多个同名块修改其中一个同名块后执行attsync不变形

本帖最后由 dcl1214 于 2025-1-1 15:10 编辑

经常会遇到用户复制粘贴图纸，同名块很多，用户可能修改了其中一个块，一旦执行attsync会导致很多同名块一起同步了，有的时候并不希望修改其它的同名块，能否让attsync的时候不会修改其它同名块呢？请看下面的代码

(defun $kuai-chong-fu-rename-copy-insert$
       (ent km-new-str lst / $block-rename$ ent-new ents i km-new mark name2 pt ss)
          ;同名块中修改其中一个块
(defun $block-rename$
   (ent oldname newname lst / blocks blk rename obj)
          ;修改块名
          ;($block-rename$ (car (entsel)) nil "dx777" nil)($block-rename$ nil "电线7" "dx777" nil)
    (IFENT
      (PROGN
(if (not oldname)
    (if ent
      (progn
      (if (= (TYPE ent) 'ENAME)
    (SETQ OBJ (vlax-ename->vla-object ent))
      )
      (setq oldname (vl-catch-all-apply
            'vla-get-effectivename
            (list obj)
          )
      )
      (if (vl-catch-all-error-p oldname)
    (setq
      oldname
       (vl-catch-all-apply 'vla-get-name (list obj))
    )
      )
      (if (vl-catch-all-error-p oldname)
    (setq oldname nil)
      )
      )
    )
)
(if newname
    (progn
      (setq
      blocks (vla-get-blocks
         (vla-get-activeDocument (vlax-get-acad-object))
         )
      )
      (setq
      blk (vl-catch-all-apply 'vla-item (list blocks oldname))
      )
      (IF(VL-CATCH-ALL-ERROR-P blk)
      (SETQ blk NIL)
      )
      (IFblk
      (PROGN
    (vl-catch-all-apply 'vla-put-name (list blk newname))
    (setq rename (vla-get-name blk))
      )
      )
      (vl-catch-all-apply 'vlax-release-object (list blocks))
      (vl-catch-all-apply 'vlax-release-object (list blK))
    )
)
      )
    )
    rename      ;返回
)
(and
    ent
    (= (type ent) 'ename)
    (entget ent)
    (setq name2(vl-catch-all-apply
      'vla-get-name
      (list (VLAX-ENAME->VLA-OBJECT ent))
    )
    )
    (progn
      (AND (and name2 (wcmatch name2 "[,`**,]"))
   (setq name2 (strcat "`" name2))
      )
      t
    )
    (SETQ SS (SSGET "X" (LIST (CONS 2 name2))))
    (setq ents (vl-remove-if
   (function listp)
   (mapcar (function cadr) (ssnamex SS))
         )
    )
    (> (length ents) 1)
    (progn
      (or km-new-str (setq km-new-str "秦始皇"))
      (setq ss nil)
      ($block-rename$ ent nil "*w" nil)
      (and ent
   (progn
       (setq pt (cdr (assoc 10 (entget ent))))
       (vl-cmdf "copybase" pt ent "" "" pt) ;基点复制
       (setq
         mark (VLAX-VLA-OBJECT->ENAME
          (VLA-ADDPOINT
      (vla-get-ModelSpace
      (vla-get-ActiveDocument
          (vlax-get-acad-object)
      )
      )
      (VLAX-3D-POINT (LIST 0 0 0))
          )
      )
       )
       (VL-CMDF "_pasteclip" pt);基点粘贴
       (entdel ent)
       (setq ent-new (entnext mark))
       (ENTDEL mark)
       (SETQ ENT ent-new)
   )
      )
      (and
ent-new
(progn
    (setq i 0)
    (WHILE
      (SETQ km-new (STRCAT km-new-str "_" (itoa (setq i (1+ i)))))
    )
    ($block-rename$ ent-new nil km-new nil)
)
      )
      (MAPCAR
(FUNCTION (LAMBDA (A / KM)
      (and a
       (entget a)
       (progn
         (WHILE
         (SETQ km-new (STRCAT km-new-str
            "_"
            (itoa (setq i (1+ i)))
            )
         )
         )
         ($block-rename$ A nil km-new nil)
       )
      )
      )
)
ents
      )
    )
)
ENT
)

我爱lisp 发表于 2025-1-1 16:11:56

2025年希望lisp这个行业继续发扬光大

树櫴希德 发表于 2025-1-1 17:50:51

主要是CASS高程点问题

chslwj521 发表于 2025-1-2 08:42:50

我爱lisp 发表于 2025-1-1 16:11
2025年希望lisp这个行业继续发扬光大

这是老鸟，请收下我的膝盖

null. 发表于 2025-1-2 15:57:09

执行后，不能用。
命令: ($kuai-chong-fu-rename-copy-insert$ (car (entsel))"dx777" nil)
选择对象:
*无效选择*
需要点或 窗口(W)/上一个(L)/窗交(C)/框(BOX)/全部(ALL)/栏选(F)/圈围(WP)/圈交(CP)/编组(G)/添加(A)/删除(R)/多个(M)/前一个(P)/放弃(U)/自动(AU)/单个(SI)/子对象(SU)/对象(O)
参数类型错误: numberp: nil
选择对象: *取消*

----还有一个问题-----------
还有一个问题，楼主的程序，为什么总带一个lst，没有用的参数。这在写程序上这个lst参数用什么用处呢，我一直很困惑。

llsheng_73 发表于 2025-1-2 21:53:35

搞完后好象各个参照所引用的块名称都不一样了吧？

kozmosovia 发表于 2025-1-2 22:25:18

他这个本质上就是个块名克隆。简单几行代码的事搞100多行。

yefei812678 发表于 2025-1-25 15:00:38

谢谢分享谢谢分享

查看完整版本: 多个同名块修改其中一个同名块后执行attsync不变形