框选范围内块重命名

江南十笑

图纸中有10个A块  框选其中5个，将选中的5个块重命名为B块  位置 基点均不变 用LISP怎么操作？

CAD新军

这个有现成的。但论坛现在上传不了附件，应该是论坛里的，原来脱编码部分有点bug，我改好了你试试
;;主程序,部分块重命名
(defun c:pbr()(c:partBlcokRename))
(defun c:partBlcokRename (/ ss OldNam NewNam loop x)
        (princ "\n请先选择一个块作为样板获取原块名信息")
        (if (setq ss(ssget ":E:S" '((0 . "INSERT")(2 . "~`*"))))
                (progn
                        (setq OldNam (cdr (assoc 2 (entget (ssname ss 0)))))
                        (setq loop T)
                        (while loop
                                (setq NewNam (getstring (strcat "\请输入新块名（字符规范,不要重名）<"OldNam">")))
                                (if (tblsearch "block" NewNam)
                                        (princ "\n错误提示--和已有块名重复!")
                                        (progn
                                            ;增加块名含脱码字符时的支持，如 10#abc的块名会copyobject 为 10`#abc引起出错 #.1 反而应该是ssget的oldname应该脱码
                                            ;(setq NewNamNoEscape NewNam)
                                                ;(setq NewNam (LM:escapewildcards NewNam))
                                                (setq OldNamEscape (LM:escapewildcards OldNam))
                                                (if (or
                                                                        (vl-string-search "`*" NewNam)
                                                                        (vl-string-search "`<" NewNam)
                                                                        (vl-string-search "`>" NewNam)
                                                                )
                                                        (princ "\n错误提示--不要带特殊字符,如:*<>等")
                                                        (setq loop nil)
                                                )
                                        )
                                )
                        )
                        ; #.2
                        (LM:CopyBlockDefinition OldNam NewNam);;生成新的块定义
                        ;(LM:CopyBlockDefinition OldNam NewNamNoEscape);;生成新的块定义
                        (while (and (princ "\n循环中---选择需要重命名的部分块,直接确定退出程序")
                                                         (setq ss(ssget (list '(0 . "INSERT")(cons 2 OldNamEscape))))
                                                 )
                                (setq n (sslength ss))
                                (setq ss(ss-enlst ss))
                                (foreach x ss
                                        (redraw x 3);1标准2空白3高亮4低亮;
                                        (xyp-SubUpd x 2 NewNam);;替换块名
                                )
                                (princ "\n")
                                (princ n)
                                (princ "个块部分重命名成功>>>>>>>>>>>>>>>>>>")
                        )
                )
                (princ "\n错误提示--未按要求选择普通块")
        )
        (princ)
)
(defun xyp-SubUpd (ename code val / ent x y i s1)
        (cond ((= (type ename) 'ENAME)
                                        (setq ent (entget ename))
                                        (if (and (= (type code) 'LIST) (= (type val) 'LIST))
                                                (mapcar '(lambda (x y) (xyp-SubUpd ename x y)) code val)
                                                (progn
                                                        (if (= (xyp-get-dxf code ename) nil)
                                                                (entmod (append ent (list (cons code val))))
                                                                (entmod (subst (cons code val) (assoc code ent) ent))
                                                        )
                                                        (entupd ename)
                                                )
                                        )
                                )
                ((= (type ename) 'PICKSET)
                        (setq i -1)
                        (while (setq s1 (ssname ename (setq i (1+ i))))
                                (xyp-SubUpd s1 code val)
                        )
                )
                ((= (type ename) 'LIST)
                        (foreach s1 ename (xyp-SubUpd s1 code val))
                )
        )
        ename
)
;; xyp-get-DXF 实体dxf数据 (xyp-get-DXF code ename)
(defun xyp-get-DXF (code ename / ent lst a)
        (if (= (type code) 'LIST)
                (progn
                        (setq ent        (entget ename)
                                lst        '()
                        )
                        (foreach a code
                                (setq lst (cons (list a (cdr (assoc a ent))) lst))
                        )
                        (reverse lst)
                )
                (if        (= code -3)
                        (cdr (assoc code (entget ename '("*"))))
                        (cdr (assoc code (entget ename)))
                )
        )
)
;;复制块定义
;; Copy Block Definition  -  Lee Mac
;; Duplicates a block definition, with the copied definition assigned the name provided.
;; blk - [str] name of block definition to be duplicated
;; new - [str] name to be assigned to copied block definition
;; Returns the copied VLA Block Definition Object, else nil
(defun LM:CopyBlockDefinition ( blk new / abc app dbc dbx def doc rtn vrs )
        (setq dbx
                (vl-catch-all-apply 'vla-getinterfaceobject
                        (list (setq app (vlax-get-acad-object))
                                (if (< (setq vrs (atoi (getvar 'acadver))) 16)
                                        "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa vrs))
                                )
                        )
                )
        )
        (cond
                (   (or (null dbx) (vl-catch-all-error-p dbx))
                        (prompt "\nUnable to interface with ObjectDBX.")
                )
                (   (and
                                        (setq doc (vla-get-activedocument app)
                                                abc (vla-get-blocks doc)
                                                dbc (vla-get-blocks dbx)
                                                def (LM:getitem abc blk)
                                        )
                                        (not (LM:getitem abc new))
                                )
                        (vlax-invoke doc 'copyobjects (list def) dbc)
                        (vla-put-name (setq def (LM:getitem dbc  blk)) new)
                        (vlax-invoke dbx 'copyobjects (list def) abc)
                        (setq rtn (LM:getitem abc new))
                )
        )
        (if (= 'vla-object (type dbx))
                (vlax-release-object dbx)
        )
        rtn
)
;; VLA-Collection: Get Item  -  Lee Mac
;; Retrieves the item with index 'idx' if present in the supplied collection
;; col - [vla]     VLA Collection Object
;; idx - [str/int] Index of the item to be retrieved
(defun LM:getitem ( col idx / obj )
        (if (not (vl-catch-all-error-p (setq obj (vl-catch-all-apply 'vla-item (list col idx)))))
                obj
        )
)
;;脱编码
(defun LM:escapewildcards ( str )
        (if (wcmatch str "*[-#@.*?~`[`,]*,*`]*")
                (if (wcmatch str "[-#@.*?~`[`,]*,`]*")
                        (strcat "`" (substr str 1 1) (LM:escapewildcards (substr str 2)))
                        (strcat     (substr str 1 1) (LM:escapewildcards (substr str 2)))
                )
                str
        )
)
;选择集与对象名表互转
(defun ss-enlst        (ss / enlst)
        (cond
                ((= (type ss) 'PICKSET)
                        (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
                )
                ((= (type ss) 'LIST)
                        (setq enlst (ssadd))
                        (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
                )
        )
)

caoyin

框选的对象叫块参照(INSERT),重命名的叫块定义(BLOCK)

江南十笑

CAD新军 发表于 2021-1-19 11:05
这个有现成的。但论坛现在上传不了附件，应该是论坛里的，原来脱编码部分有点bug，我改好了你试试
;;主程 ...

谢谢 经测试可以

paulpipi

好用，谢谢分享

magicheno

好东西，支持支持~~~

shanquanr

这个功能很好

oldskooler

感谢分享，，这个功能很好

whxiaopu

函数被取消

白色微風1991

感謝分享，，