(国外搬运）用CSV文件重命名图块和图层

panliang9 · 发表于 2022-12-26 17:00

本帖最后由 panliang9 于 2022-12-26 17:18 编辑

这是一个用CSV文件来重命名所有图块或者图层的程序，我一段段的粘到CAD里可以有用，但一整个调用就不对了。谁有空帮我调一下。

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-rename-layers-blocks-based-on-a-csv-txt-file/m-p/9713623#M403905

原贴附件

;; gc:str2lst;; Transforme un chaine avec séparateur en liste de chaines;;;; Arguments;; str : la chaîne;; sep : le séparateur(defun gc:str2lst (str sep / pos) (if (setq pos (vl-string-search sep str)) (cons (substr str 1 pos) (gc:str2lst (substr str (+ (strlen sep) pos 1)) sep)) (list str) ))(defun oe:RenBlock (old new) (if (and (tblsearch "BLOCK" old) (not (tblsearch "BLOCK" new)) (snvalid new) ) (progn (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-name (list (vla-item (vla-get-blocks (cond (*AcadDoc*) ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))) ) ) old ) new ) ) ) (princ (strcat "\nBlock: " old " could not be renamed to: " new)) (princ (strcat "\nBlock: " old " renamed to: " new)) ) ) ))(defun oe:RenLayer (old new) (if (and (tblsearch "LAYER" old) (not (tblsearch "LAYER" new)) (snvalid new) ) (progn (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-name (list (vla-item (vla-get-layers (cond (*AcadDoc*) ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))) ) ) old ) new ) ) ) (princ (strcat "\nLayer: " old " could not be renamed to: " new)) (princ (strcat "\nLayer: " old " renamed to: " new)) ) ) ))(defun C:RenBlock ( / sFile oFile sInfos) (if (and (setq sFile (getfiled "Select a block CSV File" (getvar "DWGPREFIX") "CSV" 8)) (setq sFile (findfile sFile)) ) (progn (setq sSep (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (setq oFile (open sFile "r")) (while (setq sLine (read-line oFile)) (setq sInfos (gc:str2lst sLine sSep)) (if (= (length sInfos) 2) (oe:RenBlock (car sInfos) (cadr sInfos)) ) ) (close oFile) ) ) (princ))(defun C:RenLayer ( / sFile oFile sInfos) (if (and (setq sFile (getfiled "Select a layer CSV File" (getvar "DWGPREFIX") "CSV" 8)) (setq sFile (findfile sFile)) ) (progn (setq sSep (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (setq oFile (open sFile "r")) (while (setq sLine (read-line oFile)) (setq sInfos (gc:str2lst sLine sSep)) (if (= (length sInfos) 2) (oe:RenLayer (car sInfos) (cadr sInfos)) ) ) (close oFile) ) ) (princ))

lxl217114 · 发表于 2022-12-26 18:53

本帖最后由 lxl217114 于 2022-12-26 18:58 编辑

谢谢大佬分享实用工具

中国梦 · 发表于 2022-12-26 20:02

谢谢楼主分享

hzyhzjjzh · 发表于 2022-12-27 13:07

谢谢楼主分享

xyp1964 · 发表于 2022-12-27 13:21

;; (gc:str2lst "CAP;block capacit" ";") → ("CAP" "block capacit")
(defun gc:str2lst (str sep / pos)
(if (setq pos (vl-string-search sep str))
(cons (substr str 1 pos)
(gc:str2lst (substr str (+ (strlen sep) pos 1)) sep)
)
(list str)
)
)
(defun oe:RenBlock (old new)
(if (and (tblsearch "BLOCK" old)
(not (tblsearch "BLOCK" new))
(snvalid new)
)
(if (vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-name
(list
(vla-item (vla-get-blocks
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
)
)
)
old
)
new
)
)
)
(princ
(strcat "\nBlock: " old " could not be renamed to: " new)
)
(princ (strcat "\nBlock: " old " renamed to: " new))
)
)
)
(defun oe:RenLayer (old new)
(if (and (tblsearch "LAYER" old)
(not (tblsearch "LAYER" new))
(snvalid new)
)
(if (vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-name
(list
(vla-item (vla-get-layers
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
)
)
)
old
)
new
)
)
)
(princ
(strcat "\nLayer: " old " could not be renamed to: " new)
)
(princ (strcat "\nLayer: " old " renamed to: " new))
)
)
)
(defun C:RenBlock (/ sFile oFile sInfos)
(if (and (setq sFile (getfiled "Select a block CSV File"
(getvar "DWGPREFIX")
"CSV"
8
)
)
(setq sFile (findfile sFile))
)
(progn
(setq oFile (open sFile "r"))
(while (setq sLine (read-line oFile))
(setq sInfos (gc:str2lst sLine ";"))
(if (= (length sInfos) 2)
(oe:RenBlock (car sInfos) (cadr sInfos))
)
)
(close oFile)
)
)
(princ)
)
(defun C:RenLayer (/ sFile oFile sInfos)
(if (and (setq sFile (getfiled "Select a layer CSV File"
(getvar "DWGPREFIX")
"CSV"
8
)
)
(setq sFile (findfile sFile))
)
(progn
(setq oFile (open sFile "r"))
(while (setq sLine (read-line oFile))
(setq sInfos (gc:str2lst sLine ";"))
(if (= (length sInfos) 2)
(oe:RenLayer (car sInfos) (cadr sInfos))
)
)
(close oFile)
)
)
(princ)
)

;; (gc:str2lst "CAP;block capacit" ";") → ("CAP" "block capacit") 
(defun gc:str2lst (str sep / pos) 
  (if (setq pos (vl-string-search sep str)) 
    (cons (substr str 1 pos) 
          (gc:str2lst (substr str (+ (strlen sep) pos 1)) sep) 
    ) 
    (list str) 
  ) 
) 
 
(defun oe:RenBlock (old new) 
  (if (and (tblsearch "BLOCK" old) 
           (not (tblsearch "BLOCK" new)) 
           (snvalid new) 
      ) 
    (if        (vl-catch-all-error-p 
          (vl-catch-all-apply 
            'vla-put-name 
            (list 
              (vla-item        (vla-get-blocks 
                          (cond        (*AcadDoc*) 
                                ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))) 
                                ) 
                          ) 
                        ) 
                        old 
              ) 
              new 
            ) 
          ) 
        ) 
      (princ 
        (strcat "\nBlock: " old " could not be renamed to: " new) 
      ) 
      (princ (strcat "\nBlock: " old " renamed to: " new)) 
    ) 
  ) 
) 
(defun oe:RenLayer (old new) 
  (if (and (tblsearch "LAYER" old) 
           (not (tblsearch "LAYER" new)) 
           (snvalid new) 
      ) 
    (if        (vl-catch-all-error-p 
          (vl-catch-all-apply 
            'vla-put-name 
            (list 
              (vla-item        (vla-get-layers 
                          (cond        (*AcadDoc*) 
                                ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))) 
                                ) 
                          ) 
                        ) 
                        old 
              ) 
              new 
            ) 
          ) 
        ) 
      (princ 
        (strcat "\nLayer: " old " could not be renamed to: " new) 
      ) 
      (princ (strcat "\nLayer: " old " renamed to: " new)) 
    ) 
  ) 
) 
(defun C:RenBlock (/ sFile oFile sInfos) 
  (if (and (setq sFile (getfiled "Select a block CSV File" 
                                 (getvar "DWGPREFIX") 
                                 "CSV" 
                                 8 
                       ) 
           ) 
           (setq sFile (findfile sFile)) 
      ) 
    (progn 
      (setq oFile (open sFile "r")) 
      (while (setq sLine (read-line oFile)) 
        (setq sInfos (gc:str2lst sLine ";")) 
        (if (= (length sInfos) 2) 
          (oe:RenBlock (car sInfos) (cadr sInfos)) 
        ) 
      ) 
      (close oFile) 
    ) 
  ) 
  (princ) 
) 
 
(defun C:RenLayer (/ sFile oFile sInfos) 
  (if (and (setq sFile (getfiled "Select a layer CSV File" 
                                 (getvar "DWGPREFIX") 
                                 "CSV" 
                                 8 
                       ) 
           ) 
           (setq sFile (findfile sFile)) 
      ) 
    (progn 
      (setq oFile (open sFile "r")) 
      (while (setq sLine (read-line oFile)) 
        (setq sInfos (gc:str2lst sLine ";")) 
        (if (= (length sInfos) 2) 
          (oe:RenLayer (car sInfos) (cadr sInfos)) 
        ) 
      ) 
      (close oFile) 
    ) 
  ) 
  (princ) 
)

panliang9 · 发表于 2022-12-27 17:11

谢谢 “xyp1964”！！！！

BHL-DONG · 发表于 2022-12-27 19:41

论坛里面真的是藏龙卧虎啊

ninja37 · 发表于 2022-12-28 10:03

谢大佬分享实用工具

ferious · 发表于 2023-4-21 10:34

xyp1964 发表于 2022-12-27 13:21

加载了无gc命令？

bing00 · 发表于 2023-8-18 18:26

试了下不能用吧

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

[讨论] (国外搬运）用CSV文件重命名图块和图层

本帖子中包含更多资源

点评