框选范围内块重命名
图纸中有10个A块框选其中5个，将选中的5个块重命名为B块位置 基点均不变 用LISP怎么操作？本帖最后由 CAD新军 于 2021-1-19 14:44 编辑
这个有现成的。但论坛现在上传不了附件，应该是论坛里的，原来脱编码部分有点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 - name of block definition to be duplicated
;; new - 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 dbcblk)) 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 Collection Object
;; idx - 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))
)
)
)
框选的对象叫块参照(INSERT),重命名的叫块定义(BLOCK) CAD新军 发表于 2021-1-19 11:05
这个有现成的。但论坛现在上传不了附件，应该是论坛里的，原来脱编码部分有点bug，我改好了你试试
;;主程 ...
谢谢 经测试可以 好用，谢谢分享 好东西，支持支持~~~ 这个功能很好{:1_1:} 感谢分享，，这个功能很好 函数被取消 感謝分享，，
页:
[1]
2