批量将目录下dwg文件制作成图库程序所需的幻灯片文件~

77077 · 发表于 2015-5-4 22:49

改自他人程序，我只是进行再加工而已~~~

;程序执行：TT
;制作图库幻灯片
;将目标文件夹下的每个文件执行“清理-缩放-写出幻灯片-保存关闭”；
(vl-load-com)
(defun getFolder (str_title str_prompt /)
(strcat (vl-string-right-trim "\" (strcase (acet-ui-pickdir str_prompt (vl-string-right-trim "\" "") str_title))) "\")
)
(defun makeDirectory (dir / )
(vl-mkdir dir)
)
(defun userundo()
(setq *error* errtmp)
(setvar "cmdecho" old_cmdecho)
(setvar "acadlspasdoc" old_acadlspasdoc)
(princ)
)
(defun err (msg)
(userundo)
)
;主程序开始
(defun c:TT ( / app doc docs err errtmp file files newpath old_acadlspasdoc old_cmdecho path sset)
(setq errtmp *error*)
(setq *error* err)
(setq old_cmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq old_acadlspasdoc (getvar "acadlspasdoc"))
(setvar "acadlspasdoc" 0)
(setq path (getFolder "请选择目录..." "请选择目录："))
(setq files (vl-directory-files path "*.dwg" 1))
(if files
(progn
(setq scrfile (strcat path "batpurge.scr"))
(setq fn (open scrfile "w"))
(foreach file files
(setq str (strcat "open " "path file "" purge all * no Zoom E mslide " "path (vl-string-right-trim ".dwg" file)".sld" "" qsave close"))
(write-line str fn)
(princ)
)
(close fn)
)
(alert "所选目录无 .dwg 文件！请重新选择：")
)
(command "script" scrfile)
(userundo)
(setq *error* errtmp)
(princ)
)

;程序执行：TT 
;制作图库幻灯片 
;将目标文件夹下的每个文件执行“清理-缩放-写出幻灯片-保存关闭”； 
(vl-load-com) 
(defun getFolder (str_title str_prompt /) 
    (strcat (vl-string-right-trim "\" (strcase (acet-ui-pickdir str_prompt (vl-string-right-trim "\" "") str_title))) "\") 
) 
(defun makeDirectory (dir / ) 
    (vl-mkdir dir) 
) 
 
(defun userundo() 
    (setq *error* errtmp) 
    (setvar "cmdecho" old_cmdecho) 
    (setvar "acadlspasdoc" old_acadlspasdoc) 
    (princ) 
) 
 
(defun err (msg) 
  (userundo) 
) 
;主程序开始 
(defun c:TT ( / app doc docs err errtmp file files newpath old_acadlspasdoc old_cmdecho path sset) 
  (setq errtmp *error*) 
  (setq *error* err) 
    (setq old_cmdecho (getvar "cmdecho")) 
    (setvar "cmdecho" 0) 
    (setq old_acadlspasdoc (getvar "acadlspasdoc")) 
    (setvar "acadlspasdoc" 0) 
  (setq path (getFolder "请选择目录..." "请选择目录：")) 
  (setq files (vl-directory-files path "*.dwg" 1)) 
  (if files 
        (progn 
                (setq scrfile (strcat path "batpurge.scr")) 
                (setq fn (open scrfile "w")) 
                (foreach file files 
                    (setq str (strcat "open " "path file "" purge all * no Zoom E mslide " "path (vl-string-right-trim ".dwg" file)".sld" "" qsave close")) 
                    (write-line str fn) 
                    (princ) 
                ) 
                (close fn) 
        ) 
    (alert "所选目录无 .dwg 文件！请重新选择：") 
  ) 
    (command "script" scrfile) 
    (userundo) 
  (setq *error* errtmp) 
  (princ) 
)

muwind · 发表于 2020-8-21 22:05

有个很奇怪的问题，比如楼主代码中的 (setq DWG (strcat DWG_DIR "\" DWG)) ，我一直用的 (setq DWG (strcat DWG_DIR "\\" DWG)) 特殊字符不是需要转义么？

xvjiex · 发表于 2020-9-2 16:40

错误: no function definition: ACET-UI-PICKDIR 。楼主能否提供一下函数及子函数(如有)，谢谢！

77077 · 发表于 2015-5-4 23:11

(vl-load-com)
;将CAD图形DWG文件批量转成幻灯片
(defun C:DWG2SLD (/ ACADOBJ DOC DWG_DIR DWG_LST NAME SDI)
(defun CJW-FILE-GET (MSG / WINSHELL SHFOLDER PATH CATCHIT)
(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
)
)
(princ
"\n将CAD图形DWG文件批量转成幻灯片(DWGTOSLD) By carrot1983 2009-05-10"
)
(setvar "CMDECHO" 0)
(alert "\n注意: 备份原图!!!")
(if (and (setq DWG_DIR (CJW-FILE-GET "选择DWG文件夹"))
(setq DWG_LST (vl-directory-files DWG_DIR "*.DWG" 1))
)
(progn
(foreach DWG DWG_LST
(if (setq SS (ssget "x"))
(command "._ERASE" SS "")
)
(setq DWG (strcat DWG_DIR "\" DWG))
(setq SLD (strcat DWG_DIR "\" (vl-filename-base DWG) ".sld"))
(command ".-INSERT" DWG "_NON" '(0. 0. 0.) "1" "1" "0")
(command "._ZOOM" "_E")
(command "._MSLIDE" SLD)
(print SLD)
)
(alert "程序完毕 <DWG2SLD>")
)
)
(princ)
)再来个萝卜的~~

(vl-load-com) 
;将CAD图形DWG文件批量转成幻灯片 
(defun C:DWG2SLD (/ ACADOBJ DOC DWG_DIR DWG_LST NAME SDI) 
  (defun CJW-FILE-GET (MSG / WINSHELL SHFOLDER PATH CATCHIT) 
    (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 
    ) 
  ) 
  (princ 
    "\n将CAD图形DWG文件批量转成幻灯片(DWGTOSLD) By carrot1983 2009-05-10" 
  ) 
  (setvar "CMDECHO" 0) 
  (alert "\n注意: 备份原图!!!") 
  (if (and (setq DWG_DIR (CJW-FILE-GET "选择DWG文件夹")) 
           (setq DWG_LST (vl-directory-files DWG_DIR "*.DWG" 1)) 
      ) 
    (progn 
      (foreach DWG DWG_LST 
        (if (setq SS (ssget "x")) 
          (command "._ERASE" SS "") 
        ) 
        (setq DWG (strcat DWG_DIR "\" DWG)) 
        (setq SLD (strcat DWG_DIR "\" (vl-filename-base DWG) ".sld")) 
        (command ".-INSERT" DWG "_NON" '(0. 0. 0.) "1" "1" "0") 
        (command "._ZOOM" "_E") 
        (command "._MSLIDE" SLD) 
        (print SLD) 
      ) 
      (alert "程序完毕 <DWG2SLD>") 
    ) 
  ) 
  (princ) 
)再来个萝卜的~~

伪书虫86 · 发表于 2015-5-5 07:29

谢谢分享，赞一个

VBALISPER · 发表于 2015-5-5 09:45

谢谢,正是所需.

wyl605 · 发表于 2015-5-7 12:04

太好了谢谢楼主这个好用........

我爱lisp · 发表于 2015-5-10 09:50

非常好用，建议加精

lxdz443 · 发表于 2015-5-10 11:32

谢谢。这个程序不错

tooo · 发表于 2015-5-11 11:23

有类似的需求，拿来借鉴一下。谢谢分享。

WCEO · 发表于 2016-6-2 22:49

过来看看没明白怎么用。。。

传奇 · 发表于 2016-6-3 07:06

WCEO 发表于 2016-6-2 22:49
过来看看没明白怎么用。。。

文件在那里，怎么没看见，有的朋友能发一下吗？

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

[源码] 批量将目录下dwg文件制作成图库程序所需的幻灯片文件~

点评

评分

相关帖子

点评

评分