删除绑定参照的图层名字前缀和线型名字前缀

hongxibao

麻烦大侠帮个忙！写个lsp
绑定参照后，把带进的图层名字和线型名字$0$之前前缀全部删掉（图纸说不定被二次参照，名字带有两个或三个$0$）

删除前缀时，如果有名字重合，则可以合并名字，如果不能合并，就在名字后面加个数字，比如1（加数字后，如果还有重合，继续循环运行加数字1，直到不重合）

KO你

快捷键  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

只有简单的去除前缀。

(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)

)

love_cq

非常好的资料，多谢楼主分享。

Ming131564

终于找到了，试试，感谢

290887497

感谢感谢

Quon

(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)
)

tensir

感谢作者的分享！

CAD智能@未来

刚好之前写过这个插件，下面是演示视频，你看是你需要的吗？
https://www.toutiao.com/video/73 ... e278e_1721956511515

muai2010

感谢分享....