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

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

改自他人程序，我只是进行再加工而已~~~;程序执行：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:32

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

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

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

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

(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:46

谢谢分享，赞一个

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

谢谢,正是所需.

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

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

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

非常好用，建议加精

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

谢谢。这个程序不错

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

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

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

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

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

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

文件在那里，怎么没看见，有的朋友能发一下吗？
页: [1] 2
查看完整版本: 批量将目录下dwg文件制作成图库程序所需的幻灯片文件~