求逐一打开某文件夹中的DWG文件并修改保存的代码

清风明月名字 · 发表于 2014-8-6 09:04:20

一个文件夹A中有几十个DWG文件，我想用代码打开第1个DWG文件、炸开其中名称左侧为“BLOCK”的块参照，再保存关闭，再打开第二个DWG、炸开其中名称左侧为“BLOCK”的块参照，再保存关闭.如此不断循环，直到该文件夹都执行了这样的操作。
请高手帮忙写一个，LISP或VBA均可
下面传上一

个示例文件夹：

gufeng · 发表于 2014-8-6 09:04:21

本帖最后由 gufeng 于 2014-8-7 09:29 编辑

;;_把代码保存LSP,加载到CAD的启动组,执行命令test
;;_2014年8月7日获取指定目录下的DWG文件,批量执行操作(打开文件-->分解块block1-->保存) GoodLuck

(defun c:Test(/ FILE_LIST FOLD SF SFF RunNow QF_GETFOLDER GETFILELIST PATH-ADDBACKSLASH)
(vl-load-com)
;_Thanks caoyin
;_http://bbs.mjtd.com/dispbbs.asp?BoardID=3&ID=69986&replyID=&skin=0
(defun GetFileList (dirName / files lst)
(defun path-addBackSlash (path)
(if (not (member (substr path (strlen path)) '("\" "/")))
(strcat path "\")
path
)
)
(setq dirName (path-addBackSlash dirName)
files (mapcar '(lambda (x) (strcat dirName x))
(vl-directory-files dirName "*.dwg" 1)
)
)
(mapcar '(lambda (x)
(setq lst (append lst (GetFileList (strcat dirName x))))
)
(vl-remove-if
'(lambda (x) (member x '("." "..")))
(vl-directory-files dirName nil -1)
)
)
(append files lst)
)
;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认.
;; ========================================================
;; 作者：秋枫，参考了灯火的VBA程序
;; 用法：(qf_getFolder msg)
;; 例子：(qf_getFolder "选择文件夹:")
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil
;; http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=302
(defun qf_getFolder (msg / WinShell shFolder path catchit)
(vl-load-com)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
(setq
catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
)
(setq fold (qf_getFolder "选择文件所在目录:"))
(if fold
(progn
(setq file_list (GetFileList fold))
(if file_list
(progn
(setq sf (strcat (getvar "TEMPPREFIX") "批处理文件201408.scr"))
(setq sff (open sf "w"))
(mapcar '(lambda (x)
(princ (strcat "open "" x ""\n" "(explode_block1) qsave close\n") sff)
)
file_list
)
(close sff)
(princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list))))
(initget "Y N")
(setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>"))
(if (= RunNow "Y")
(progn
(command "._script" sf)
(princ "\n处理完成")
)
(princ "\n放弃立刻执行")
)
)
(princ "\n目录下没有DWG文件")
)
)
(princ "\n请选择目录")
)
(princ)
)
(defun explode_block1 (/ OLDQAFLAGS SS)
(setq ss (ssget "x" '((0 . "INSERT") (2 . "BLOCK1"))));_分解的块名 BLOCK1
(if ss
(progn
(setq oldQAFLAGS (getvar "QAFLAGS"))
(setvar "QAFLAGS" 0)
(command "_explode" ss)
(setvar "QAFLAGS" oldQAFLAGS)
)
)
)
(princ)

(defun c:Test(/ FILE_LIST FOLD SF SFF RunNow QF_GETFOLDER GETFILELIST PATH-ADDBACKSLASH) 
(vl-load-com) 
;_Thanks caoyin 
;_http://bbs.mjtd.com/dispbbs.asp?BoardID=3&ID=69986&replyID=&skin=0 
(defun GetFileList (dirName / files lst) 
(defun path-addBackSlash (path) 
(if (not (member (substr path (strlen path)) '("\" "/"))) 
(strcat path "\") 
path 
) 
) 
(setq dirName (path-addBackSlash dirName) 
files (mapcar '(lambda (x) (strcat dirName x)) 
(vl-directory-files dirName "*.dwg" 1) 
) 
) 
(mapcar '(lambda (x) 
(setq lst (append lst (GetFileList (strcat dirName x)))) 
) 
(vl-remove-if 
'(lambda (x) (member x '("." ".."))) 
(vl-directory-files dirName nil -1) 
) 
) 
(append files lst) 
) 
;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊 
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认. 
;; ======================================================== 
;; 作者：秋枫，参考了灯火的VBA程序 
;; 用法：(qf_getFolder msg) 
;; 例子：(qf_getFolder "选择文件夹:") 
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil 
;; http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=302 
(defun qf_getFolder (msg / WinShell shFolder path catchit) 
(vl-load-com) 
(setq winshell (vlax-create-object "Shell.Application")) 
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)) 
(setq 
catchit (vl-catch-all-apply 
'(lambda () 
(setq shFolder (vlax-get-property shFolder 'self)) 
(setq path (vlax-get-property shFolder 'path)) 
) 
) 
) 
(if (vl-catch-all-error-p catchit) 
nil 
path 
) 
) 
(setq fold (qf_getFolder "选择文件所在目录:")) 
(if fold 
(progn 
(setq file_list (GetFileList fold)) 
(if file_list 
(progn 
(setq sf (strcat (getvar "TEMPPREFIX") "批处理文件201408.scr")) 
(setq sff (open sf "w")) 
(mapcar '(lambda (x) 
(princ (strcat "open "" x ""\n" "(explode_block1) qsave close\n") sff) 
) 
file_list 
) 
(close sff) 
(princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list)))) 
(initget "Y N") 
(setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>")) 
(if (= RunNow "Y") 
(progn 
(command "._script" sf) 
(princ "\n处理完成") 
) 
(princ "\n放弃立刻执行") 
) 
) 
(princ "\n目录下没有DWG文件") 
) 
) 
(princ "\n请选择目录") 
) 
(princ) 
) 
(defun explode_block1 (/ OLDQAFLAGS SS) 
(setq ss (ssget "x" '((0 . "INSERT") (2 . "BLOCK1"))));_分解的块名  BLOCK1 
(if ss 
(progn 
(setq oldQAFLAGS (getvar "QAFLAGS")) 
(setvar "QAFLAGS" 0) 
(command "_explode" ss) 
(setvar "QAFLAGS" oldQAFLAGS) 
) 
) 
) 
 
(princ)

Andyhon · 发表于 2014-8-6 21:32:36

Ref Link:
http://bbs.mjtd.com/thread-110997-1-1.html

清风明月名字 · 发表于 2014-8-7 08:05:59

Andyhon 发表于 2014-8-6 21:32
Ref Link:
http://bbs.mjtd.com/thread-110997-1-1.html

里面没有我要的代码啊

Andyhon · 发表于 2014-8-7 08:45:09

...所有cad文件...运行某个Lisp程序...
框架相同,只改套个别 Lisp程序

清风明月名字 · 发表于 2014-8-8 08:17:08

gufeng 发表于 2014-8-7 09:23
;;_把代码保存LSP,加载到CAD的启动组,执行命令test
;;_2014年8月7日获取指定目录下的DWG文件,批量执行操 ...

批处理文件201408.scr
上面说的文件在哪里？

清风明月名字 · 发表于 2014-8-8 08:32:29

gufeng 发表于 2014-8-7 09:23
;;_把代码保存LSP,加载到CAD的启动组,执行命令test
;;_2014年8月7日获取指定目录下的DWG文件,批量执行操 ...

命令: (LOAD "E:/E盘DXM文件夹/有用别删除/逐一打开某文件夹中的DWG文件并修改保存的LISP代码.lsp") ; 错误: 输入中的点位置不正确

清风明月名字 · 发表于 2014-8-8 08:38:03

很奇怪，拖入CAD命令窗口加载就不正确，在CAD的LISP编辑窗口加载就正确。这是为什么？

gufeng · 发表于 2014-8-8 09:46:19

清风明月名字发表于 2014-8-8 08:32
命令: (LOAD "E:/E盘DXM文件夹/有用别删除/逐一打开某文件夹中的DWG文件并修改保存的LISP代码.lsp") ; 错 ...

我这测试拖入CAD窗口没问题,是否你本身的CAD已经存在此问题?可以找另外个LSP试下,

清风明月名字 · 发表于 2014-8-8 18:42:09

谢谢了！用VBA来完成这种任务更准确高效。

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

求逐一打开某文件夹中的DWG文件并修改保存的代码

最佳答案

相关帖子