社区 › 源码共享 › 几个visual lisp程序

337099425 发表于 2012-3-27 17:29:57

做什么用的啊

srv2 发表于 2012-7-9 14:36:17

本帖最后由 srv2 于 2012-7-9 14:37 编辑

看起來怪怪的, 好像要對 AUTOEXEC.BAT 做什麼事.


;;; Description:
;;; This following module's function is based on FSO(File System Object).
(vl-load-com)
(defun fso::fso ( / obj)
(setq obj (vlax-create-object "Scripting.FileSystemObject"))
)
; Initialize global variable
(setq fso (fso::fso))
;;; Error handling codes.
(setq $orr *error* *error* #err)
(defun #err (s)
(princ (strcat "\nError: " s))
(setq *error* $orr)
(princ)
)
;;; Property Function
(defun fso::Drives ( / dri)
(vlax-get-property (fso::fso) 'Drives)
)
;;; Method Function
;;; Parameter: Path(String), Name(String)
;;; Example: _$ (fso::BuildPath "C:\\Program Files\\AutoCAD 2004" "acad.exe")
;;;          "C:\\Program Files\\AutoCAD 2004\\acad.exe"
(defun fso::BuildPath (Path Name / )
(vlax-invoke-method (fso::fso) 'BuildPath path name)
)
;;; Parameter: Source(String), Destination(String), OverWriteFiles(Boolean)
;;; Example: _$ (fso::CopyFile "C:\\AUTOEXEC.BAT" "D:\\" T)
;;;          "D:\\AUTOEXEC.BAT"
(defun fso::CopyFile (Source Destination OverWriteFiles / Name ret)
(if (and
(setq Name
      (if (= (vlax-invoke-method fso 'FileExists Source) :vlax-True)
   (vlax-get-property
   (vlax-invoke-method fso 'GetFile Source)
   'Name
   )
   nil
      )
       ret (strcat Destination Name)
)
(= (vlax-invoke-method fso 'FolderExists Destination) :vlax-True)
      )
    (progn
      (if (= (vlax-invoke-method fso 'FileExists ret) :vlax-False)
(progn
   (vlax-invoke-method fso 'CopyFile Source Destination OverWriteFiles)
   ret
)
(progn
   (setq OverWriteFiles (if OverWriteFiles T nil))
   (if (= OverWriteFiles T)
   (progn
       (vlax-invoke-method fso 'CopyFile Source Destination OverWriteFiles)
       ret
   )
   ret
   )
)
      )
    )
    nil
)
)
;;; Parameter: Source(String), Destination(String), OverWriteFiles(Boolean)
;;; Example: _$ (fso::CopyFolder "C:\\Test" "D:\\" T)
;;;          "D:\\Test "
(defun fso::CopyFolder (Source Destination OverWriteFiles / Name ret)
(if (and
(setq Name
      (if (= (vlax-invoke-method fso 'FolderExists Source) :vlax-True)
   (vlax-get-property
   (vlax-invoke-method fso 'GetFolder Source)
   'Name
   )
   nil
      )
       ret (strcat Destination Name)
)
(= (vlax-invoke-method fso 'FolderExists Destination) :vlax-True)
      )
    (progn
      (if (= (vlax-invoke-method fso 'FolderExists ret) :vlax-False)
(progn
   (vlax-invoke-method fso 'CopyFolder Source Destination OverWriteFiles)
   ret
)
(progn
   (setq OverWriteFiles (if OverWriteFiles T nil))
   (if (= OverWriteFiles T)
   (progn
       (vlax-invoke-method fso 'CopyFolder Source Destination OverWriteFiles)
       ret
   )
   ret
   )
)
      )
    )
    nil
)
)
;;; Parameter: Path(String)
;;; Example: _$ (fso::CreateFolder "C:\\Test")
;;;          "C:\\Test "
(defun fso::CreateFolder (Path)
(if (= (vlax-invoke-method fso 'FolderExists Path) :vlax-False)
    (progn
      (vlax-invoke-method fso 'CreateFolder Path)
      Path
    )
    Path
)
)
;;; Parameter: FileSpec(String)
;;; Example: _$ (fso::DeleteFile "C:\\test.txt")
;;;          T
(defun fso::DeleteFile (FileSpec)
   (if
   (and
       (= (vlax-invoke-method fso 'FileExists FileSpec) :vlax-True)
       (not
(vl-catch-all-error-p
    (vl-catch-all-apply
      'vlax-invoke-method
      (list fso 'DeleteFile FileSpec t)
    )
)
       )
   )
   t
   nil
   )
)
;;; Parameter: FolderSpec(String)
;;; Example: _$ (fso::DeleteFolder "C:\\test")
;;;          T
(defun fso::DeleteFolder (FolderSpec)
(if
    (and
      (= (vlax-invoke-method fso 'FolderExists FolderSpec) :vlax-True)
      (not
(vl-catch-all-error-p
   (vl-catch-all-apply
   'vlax-invoke-method
   (list fso 'DeleteFolder FolderSpec t)
   )
)
      )
    )
    t
    nil
)
)

xiaokai123 发表于 2012-7-21 20:03:30

顶起//

hbshyjch 发表于 2012-7-24 14:24:09

给点提示信息啊，都不知道干什么用的

辉/:) 发表于 2012-9-2 18:46:41

下了看看我能用上么

恕放之生命 发表于 2014-7-20 13:26:12

谢谢分享。

laorenhao999 发表于 2014-11-6 14:06:39

没注释也不知道干什么用的，又给删了

ketxu 发表于 2019-12-23 12:52:20

Thanks for sharing functions ^^

timmy521 发表于 2020-2-2 11:13:17

谢谢，好东西，收藏 了，

查看完整版本: 几个visual lisp程序