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

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

本帖最后由 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)
(IF ENT
(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)
)
(IF blk
(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
)

(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) 
    (IF  ENT 
      (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) 
      ) 
      (IF  blk 
        (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多行。

账号		自动登录	找回密码
密码			注册

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