求LISP程序能实现图片中的要求？

635641449

求插件程序，根据DWG文件名自动修改文件里的布局名，使布局名和文件名一致。（我的每个DWG文件是只有一个布局哦）万分感谢！

vitalgg

那你试试这一版吧， 需要在命令输入文件夹名称。(不能有空格)

安装 @lisp 不需要系统 的安装权限，能上网就可以安装。

1. (defun c:rename-layout(/ *error* dir% dwgs)
   
2.   (defun *error* (msg)
   
3.     (if (and
   
4.          (and (= 'vla-object (type doc%)))
   
5.          (null (vlax-erased-p doc%)))
   
6.         (progn
   
7.           (vla-close doc%)
   
8.           (vlax-release-object doc%)
   
9.           (vla-quit acadapp)
   
10.           ))
    
11.     (mapcar '(lambda(obj)
    
12.                (if(and (= 'vla-object (type obj))
    
13.                        (null (vlax-erased-p obj)))
    
14.                    (vlax-release-object obj)))
    
15.             (list dwgdocs% acadapp))
    
16.     (princ msg))
    
17.   (setq dir% (vl-string-right-trim "\\" (getstring "请输入要处理的文件夹<注意不能有空格>：")))
    
18.   (if (null (findfile dir%))(progn (alert "目录文件不存在。")(exit)))
    
19.   (setq dwgs (vl-directory-files dir% "*.dwg" 1))
    
20.   (setq acadapp (vlax-create-object "AutoCAD.Application"));; 这里要修改为你电脑上的版本
    
21.   (setq dwgdocs% (vla-get-documents acadapp))
    
22.   ;;
    
23.   (foreach file% dwgs
    
24.            (princ(strcat "处理dwg文件 " file% "... \n"))
    
25.            
    
26.            (vla-open dwgdocs% (strcat dir% "\\" file%))
    
27.            (setq doc% (vla-item dwgdocs% file%))
    
28.            ;;实操
    
29.            (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 0))
    
30.                    "Model")
    
31.                (vla-put-name
    
32.                 (vla-item (vla-get-layouts doc%) 0)
    
33.                 (vl-filename-base file%))
    
34.              (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 1))
    
35.                      "Model")
    
36.                  (vla-put-name
    
37.                   (vla-item (vla-get-layouts doc%) 1)
    
38.                   (vl-filename-base file%))
    
39.                ))
    
40.            ;;保存
    
41.            (vla-save doc% )
    
42.            (vla-close doc%)
    
43.            )
    
44.   (vla-quit acadapp)
    
45.   (mapcar 'vlax-release-object (list doc% dwgdocs% acadapp)))

(defun c:rename-layout(/ *error* dir% dwgs)<br />   (defun *error* (msg)<br />     (if (and<br />          (and (= 'vla-object (type doc%)))<br />          (null (vlax-erased-p doc%)))<br />         (progn<br />           (vla-close doc%)<br />           (vlax-release-object doc%)<br />           (vla-quit acadapp)<br />           ))<br />     (mapcar '(lambda(obj)<br />                (if(and (= 'vla-object (type obj))<br />                        (null (vlax-erased-p obj)))<br />                    (vlax-release-object obj)))<br />             (list dwgdocs% acadapp))<br />     (princ msg))<br />   (setq dir% (vl-string-right-trim "\\" (getstring "请输入要处理的文件夹<注意不能有空格>：")))<br />   (if (null (findfile dir%))(progn (alert "目录文件不存在。")(exit)))<br />   (setq dwgs (vl-directory-files dir% "*.dwg" 1))<br />   (setq acadapp (vlax-create-object "AutoCAD.Application"));; 这里要修改为你电脑上的版本<br />   (setq dwgdocs% (vla-get-documents acadapp))<br />   ;;<br />   (foreach file% dwgs<br />            (princ(strcat "处理dwg文件 " file% "... \n"))<br />            <br />            (vla-open dwgdocs% (strcat dir% "\\" file%))<br />            (setq doc% (vla-item dwgdocs% file%))<br />            ;;实操<br />            (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 0))<br />                    "Model")<br />                (vla-put-name<br />                 (vla-item (vla-get-layouts doc%) 0)<br />                 (vl-filename-base file%))<br />              (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 1))<br />                      "Model")<br />                  (vla-put-name<br />                   (vla-item (vla-get-layouts doc%) 1)<br />                   (vl-filename-base file%))<br />                ))<br />            ;;保存<br />            (vla-save doc% )<br />            (vla-close doc%)<br />            )<br />   (vla-quit acadapp)<br />   (mapcar 'vlax-release-object (list doc% dwgdocs% acadapp)))

vitalgg

如果无法播放，请点击此处在新窗口打开

1. (defun c:rename-layout(/ *error* dir% dwgs)
   
2.   (defun *error* (msg)
   
3.     (if (and
   
4.          (and (= 'vla-object (type doc%)))
   
5.          (null (vlax-erased-p doc%)))
   
6.         (progn
   
7.           (vla-close doc%)
   
8.           (vlax-release-object doc%)
   
9.           (vla-quit acadapp)
   
10.           ))
    
11.     (mapcar '(lambda(obj)
    
12.                (if(and (= 'vla-object (type obj))
    
13.                        (null (vlax-erased-p obj)))
    
14.                    (vlax-release-object obj)))
    
15.             (list dwgdocs% acadapp))
    
16.     (@:*error* msg))
    
17.   (setq dir% (system:get-folder "请选择要处理的文件夹："))
    
18.   (setq dwgs (vl-directory-files dir% "*.dwg" 1))
    
19.   (setq acadapp (vlax-create-object "AutoCAD.Application.24.1"));; 这里要修改为你电脑上的版本
    
20.   (setq dwgdocs% (vla-get-documents acadapp))
    
21.   ;;
    
22.   (foreach file% dwgs
    
23.            (princ(strcat "处理dwg文件 " file% "... \n"))
    
24.            
    
25.            (vla-open dwgdocs% (strcat dir% "\\" file%))
    
26.            (setq doc% (vla-item dwgdocs% file%))
    
27.            ;;实操
    
28.            (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 0))
    
29.                    "Model")
    
30.                (vla-put-name
    
31.                 (vla-item (vla-get-layouts doc%) 0)
    
32.                 (vl-filename-base file%))
    
33.              (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 1))
    
34.                      "Model")
    
35.                  (vla-put-name
    
36.                   (vla-item (vla-get-layouts doc%) 1)
    
37.                   (vl-filename-base file%))
    
38.                ))
    
39.            ;;保存
    
40.            (vla-save doc% )
    
41.            (vla-close doc%)
    
42.            )
    
43.   (vla-quit acadapp)
    
44.   (mapcar 'vlax-release-object (list doc% dwgdocs% acadapp)))

(defun c:rename-layout(/ *error* dir% dwgs)<br />   (defun *error* (msg)<br />     (if (and<br />          (and (= 'vla-object (type doc%)))<br />          (null (vlax-erased-p doc%)))<br />         (progn<br />           (vla-close doc%)<br />           (vlax-release-object doc%)<br />           (vla-quit acadapp)<br />           ))<br />     (mapcar '(lambda(obj)<br />                (if(and (= 'vla-object (type obj))<br />                        (null (vlax-erased-p obj)))<br />                    (vlax-release-object obj)))<br />             (list dwgdocs% acadapp))<br />     (@:*error* msg)) <br />   (setq dir% (system:get-folder "请选择要处理的文件夹："))<br />   (setq dwgs (vl-directory-files dir% "*.dwg" 1))<br />   (setq acadapp (vlax-create-object "AutoCAD.Application.24.1"));; 这里要修改为你电脑上的版本<br />   (setq dwgdocs% (vla-get-documents acadapp))<br />   ;;<br />   (foreach file% dwgs<br />            (princ(strcat "处理dwg文件 " file% "... \n"))<br />            <br />            (vla-open dwgdocs% (strcat dir% "\\" file%))<br />            (setq doc% (vla-item dwgdocs% file%))<br />            ;;实操<br />            (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 0))<br />                    "Model")<br />                (vla-put-name <br />                 (vla-item (vla-get-layouts doc%) 0)<br />                 (vl-filename-base file%))<br />              (if (/= (vla-get-name (vla-item (vla-get-layouts doc%) 1))<br />                      "Model")<br />                  (vla-put-name <br />                   (vla-item (vla-get-layouts doc%) 1)<br />                   (vl-filename-base file%))<br />                ))<br />            ;;保存<br />            (vla-save doc% )<br />            (vla-close doc%)<br />            )<br />   (vla-quit acadapp)<br />   (mapcar 'vlax-release-object (list doc% dwgdocs% acadapp)))

635641449

vitalgg 发表于 2022-4-24 14:05
需要安装 @lisp 。
一些函数的定义在 @lisp 函数库中。

你的这段程序就是我想要的结果，但是我的电脑没有安装@lisp，所以无法正常运行，拜托你，有没有其他办法可以在不安装函数库的情况下也能正常运行这段代码？

gaics

倒是可以参考这个帖子：请大家帮忙看看这个布局改图号的代码
http://bbs.mjtd.com/forum.php?mo ... &fromuid=410342
(出处: 明经CAD社区)

635641449

gaics 发表于 2022-4-18 07:43
倒是可以参考这个帖子：请大家帮忙看看这个布局改图号的代码
http://bbs.mjtd.com/forum.php?mod=viewthre ...

这个达不到我想要的目的，谢谢!

masterlong

不要总想着得到完全符合自己意愿的插件
没人有义务为你定向开发
稍微学点lsp
最难部分的代码已经有了
另存或改名这种小事
不能试着自己去解决？

635641449

vitalgg 发表于 2022-4-24 10:51

我的是cad2020和2023版都装了的，出现错误了

vitalgg

635641449 发表于 2022-4-24 14:00
我的是cad2020和2023版都装了的，出现错误了

需要安装 @lisp 。
一些函数的定义在 @lisp 函数库中。

@:*error*
system:get-folder

635641449

vitalgg 发表于 2022-4-24 14:05
需要安装 @lisp 。
一些函数的定义在 @lisp 函数库中。

公司电脑，没有安装权限，怎么搞哦，能不能修改一下，不需要安装函数库就能直接运行，我安装了CAD2023版的