删除绑定参照的图层名字前缀和线型名字前缀
本帖最后由 hongxibao 于 2018-9-16 03:37 编辑麻烦大侠帮个忙！写个lsp
绑定参照后，把带进的图层名字和线型名字$0$之前前缀全部删掉（图纸说不定被二次参照，名字带有两个或三个$0$）
删除前缀时，如果有名字重合，则可以合并名字，如果不能合并，就在名字后面加个数字，比如1（加数字后，如果还有重合，继续循环运行加数字1，直到不重合）
快捷键d+批量图层名称加前缀
全部图层加前缀<除0,Defpoints>
(defun c:d+ ( / YY_QIANZ *doc* LAY LAYERS OLDMING)
(vl-load-com)
(setq YY_QIANZ (getstring "\n输入图层要加的前缀:"))
(if YY_QIANZ
(progn
(setq *doc* (vla-get-activedocument (vlax-get-acad-object))
layers (vla-get-layers *doc*))
(vlax-for lay layers (setq OLDMING (vla-get-name lay))
(if (not (member OLDMING '("0" "Defpoints")))
(vla-put-Name lay (strcat YY_QIANZ OLDMING)))))))
快捷键d-批量图层名称去前缀
(defun c:d- ()
(if (setq qz (getstring "\n输入图层要删除的前缀: "))
(vlax-for la (vla-get-layers(vla-get-activedocument (vlax-get-acad-object)))
(setq tx (vla-get-name la))
(if (and (not (member tx '("0" "Defpoints")))(vl-string-search qz tx))
(vla-put-Name la (substr tx (1+ (strlen qz)))))))
(princ)) 本帖最后由 baoxiaozhong 于 2020-2-24 07:45 编辑
只有简单的去除前缀。
(defun c:RBP(/ ActDoc Name NewName)
; RemoveBindPrefixes
; Renames layers, blocks, dimension styles, text styles, user coordinate systems, and views
; by taking out the bind as bind prefix
; Example Drawing1$0$Layer1 -> Layer1
(vl-load-com)
(defun RemoveBindPrefix (String / Pos LastPos)
(if (setq Pos (vl-string-search "$" String))
(progn
(setq LastPos Pos)
(while (setq Pos (vl-string-search "$" String (1+ Pos)))
(setq LastPos Pos)
)
(substr String (+ 2 LastPos))
)
String
)
)
;---------------------------------------------------------
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vlax-for Obj (vla-get-Layers ActDoc)
(setq Name (vla-get-Name Obj))
(if (/= (setq NewName (RemoveBindPrefix Name)) Name)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list Obj NewName)))
(prompt (strcat "\n Layer: " Name " was not renamed."))
)
)
)
(vlax-for Obj (vla-get-Blocks ActDoc)
(setq Name (vla-get-Name Obj))
(if (/= (setq NewName (RemoveBindPrefix Name)) Name)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list Obj NewName)))
(prompt (strcat "\n Block: " Name " was not renamed."))
)
)
)
(vlax-for Obj (vla-get-TextStyles ActDoc)
(setq Name (vla-get-Name Obj))
(if (/= (setq NewName (RemoveBindPrefix Name)) Name)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list Obj NewName)))
(prompt (strcat "\n Text style: " Name " was not renamed."))
)
)
)
(vlax-for Obj (vla-get-Views ActDoc)
(setq Name (vla-get-Name Obj))
(if (/= (setq NewName (RemoveBindPrefix Name)) Name)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list Obj NewName)))
(prompt (strcat "\n View: " Name " was not renamed."))
)
)
)
(vlax-for Obj (vla-get-UserCoordinateSystems ActDoc)
(setq Name (vla-get-Name Obj))
(if (/= (setq NewName (RemoveBindPrefix Name)) Name)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list Obj NewName)))
(prompt (strcat "\n UCS: " Name " was not renamed."))
)
)
)
(vlax-for Obj (vla-get-DimStyles ActDoc)
(setq Name (vla-get-Name Obj))
(if (/= (setq NewName (RemoveBindPrefix Name)) Name)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list Obj NewName)))
(prompt (strcat "\n Dimension style: " Name " was not renamed."))
)
)
)
(princ)
) 非常好的资料，多谢楼主分享。 终于找到了，试试，感谢 感谢感谢:lol
国外搬运的，有大神能否帮忙修改下：若去除前缀后重名，则进行合并。悬赏20个币.
本帖最后由 Quon 于 2024-6-24 17:50 编辑(defun c:RenBLD ( / aDoc RemoveBindPrefix _taken aDoc name newname)
;;; Kent Cooper ;;;
(defun RemoveBindPrefix (String / Pos)
(if (setq Pos (vl-string-position 36 String nil T)); T = search-from-the-end
(substr String (+ 2 Pos)); then
String ; else
); if
)
;;; pBe ;;;
(defun _taken (doc tbl nm i / nme)
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-item
(list (vlax-geta doc tbl) (setq nme (strcat nm " (" (itoa i) ")")))
) ;_ end of vl-catch-all-apply
) ;_ end of vl-catch-all-error-p
) ;_ end of not
(_taken doc tbl nm (1+ i))
nme))
(setq aDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(foreach item '("Layers" "DimStyles" "TextStyles" "Blocks" "Linetypes")
(vlax-for itm (vlax-get aDoc item)
(cond ((and
(vl-string-position 36 (setq name (vla-get-name itm)) nil T)
(setq newname (RemoveBindPrefix name))
(setq newname
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-item (list (vlax-get aDoc item) newname))
) ;_ end of vl-catch-all-error-p
newname
(_taken aDoc item newname 2)
) ;_ end of if
) ;_ end of setq
(if (eq item "TextStyles")
(progn
(setq ent (entget (tblobjname "Style" name)))
(entmod (subst (Cons 2 newname) (assoc 2 ent) ent))
) ;_ end of progn
(vlax-put itm 'Name newname)
) ;_ end of if
) ;_ end of and
)
) ;_ end of cond
) ;_ end of vlax-for
) ;_ end of foreach
(princ)
)
感谢作者的分享！ 刚好之前写过这个插件，下面是演示视频，你看是你需要的吗？
https://www.toutiao.com/video/7387551485003596315/?from_scene=all&log_from=d627abdde278e_1721956511515
感谢分享....
页:
[1]
2