VisualLISP使用Windows Scripting Host 编程的示例

mccad · 发表于 2004-11-28 21:07:00

;; WSH.LSP Copyright 1999 Tony Tanzillo
;;
;; WSH.LSP demonstrates how to use the Windows Scripting
;; Host's FileSystemObject in Visual LISP Applications.
;;
;; The FileSystemObject is part of Microsoft's Windows
;; Scripting Host, which is shipped with Windows 98 and
;; Internet Explorer. You can also download and install
;; the Windows Scripting Host on any NT4 or Windows 9x
;; system by downloading it from Microsoft's web site:
;;
;; http://www.microsoft.com/scripting
;;
;; The FileSystemObject
;;
;; The FileSystemObject and its aggregates provide a
;; well-defined, high-level ActiveX interface to the
;; file system and its contents.
;;
;; Within the FileSystemObject, Drives, Folders, and
;; Files are all represented by like-named ActiveX
;; objects (Folder, File, Drive, and so on). Some of
;; those objects expose a collection property that
;; provides access to child objects.
;;
;; For example, Drive objects have a collection of
;; Folder objects. Folder objects have a collection of
;; File objects and SubFolder objects. You can use these
;; objects and collections to access and process folders
;; and files in a hierarchial fashion.
;;
;; The following is a short synopsys of the properties
;; and methods of the top-level FileSystemObject. The
;; aggregate objects within the FileSystemObject (File,
;; Folder, Drive, and so forth) are not detailed here.
;; You can get complete information on all child objects
;; from the Windows Scripting Host documentation.
;;
;; Note that the method/property/constant prefix "wsh-"
;; is VLISP-specific, as defined by the load-scripting
;; function below.
;;
;; Windows Scripting Host FileSystemObject
;; ---------------------------------------
;;
;; Properties:
;;
;; (wsh-get-Drives)
;;
;; Methods:
;;
;; (wsh-BuildPath <Path> <Name>)
;; (wsh-CopyFile <Source> <Destination> [<Overwrite = :vlax-true>])
;; (wsh-CopyFolder <Source> <Destination> [<Overwrite = :vlax-true>])
;; (wsh-CreateFolder <FolderName>)
;; (wsh-CreateTextFile <FileName> [<Overwrite = :vlax-false> [<Unicode = :vlax-false>]])
;; (wsh-DeleteFile <FileName> [<Force = :vlax-false>])
;; (wsh-DeleteFolder <FolderName> [<Force = :vlax-false>])
;; (wsh-DriveExists <DriveSpec>)
;; (wsh-FileExists <FileSpec>)
;; (wsh-FolderExists <FolderSpec>)
;; (wsh-GetAbsolutePathName <PathSpec>)
;; (wsh-GetBaseName <Path>)
;; (wsh-GetDrive <DriveSpec>)
;; (wsh-GetDriveName <Path>)
;; (wsh-GetExtensionName <Path>)
;; (wsh-GetFile <FileSpec>)
;; (wsh-GetFileName <PathSpec>)
;; (wsh-GetFolder <FolderSpec>)
;; (wsh-GetParentFolderName <Path>)
;; (wsh-GetSpecialFolder <FolderSpec>)
;; (wsh-GetTempName)
;; (wsh-MoveFile <Source> <Destination>)
;; (wsh-MoveFolder <Source> <Destination>)
;; (wsh-OpenTextFile <FileName> [<IOMode = :wsh-ForReading> [<Create = :vlax-false>
;; [<Format = :wsh-TristateFalse]]])
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Global constants(setq fso:progid "Scripting.FileSystemObject")
(setq fso:prefix "wsh-");;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Utility functions
(defun load-scripting ( / server)
(if (not wsh-get-drives)
(progn
(vl-load-com)
(setq server (CoGetClassServer fso:progid))
(if (not server)
(alert "Error: Windows Scripting Host is not installed")
(progn
(vlax-import-type-library
:tlb-filename Server
:methods-prefix fso:prefix
:properties-prefix fso:prefix
:constants-prefix (strcat ":" fso:prefix)
)
)
)
)
)
)(defun ProgID->CLSID (ProgID)
(vl-registry-read
(strcat "HKEY_CLASSES_ROOT\" progid "\\CLSID")
)
)(defun CoGetClassProperty (ProgID property / clsid)
(if (setq clsid (ProgID->CLSID ProgID))
(vl-registry-read
(strcat
"HKEY_CLASSES_ROOT\\CLSID\"
clsid
"\" property
)
)
)
)(defun CoGetClassServer (progid)
(CoGetClassProperty progid "InprocServer32")
);; load Windows Scripting Host Type Library(load-scripting) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Windows Scripting Host FileSystemObject Example:
;;
;; Function (FindFiles <Folder> <Pattern>)
;;
;; This function uses the FileSystemObject to
;; find all files in a given folder and all
;; subfolders that match a specified pattern.
;;
;; It returns a list of the full filespec of
;; each file that was found, or nil if no files
;; were found.
;;
;; Note that the pattern argument is a wcmatch-
;; style wildcard pattern, rather than a DOS
;; wildcard pattern. Hence, if you want to
;; include the period extension delimiter in the
;; pattern, you must prefix it with ` (backquote).
;;
;; Finally, this demonstration code is highly-
;; ineffecient, mainly due to the use of (append)
;; for constructing the resulting list. If you
;; are serious about processing large amounts of
;; files, you may want to consider optimizing it.
;;
;; Example (find all LISP files in D:\LISP):
;;
;; (FindFiles "D:\\LISP" "*`.LSP") ;; Note backquote!!!(defun FindFiles (FolderSpec Pattern / fso Folder rslt Find:OnSubFolder) ;; If the function find-in-folders:onSubFolder is
;; defined, it is called and passed each folder
;; object that is processed. This function could
;; be used to keep a user informed on the progress
;; of a long search operation.
(defun Find:OnSubFolder (Folder)
(princ
(strcat
" \r"
"Searching " (wsh-get-path folder)
)
)
) (setq pattern (strcase pattern))
(setq fso
(vla-getInterfaceObject
(vlax-get-acad-object)
"Scripting.FileSystemObject"
)
)
(setq folder (wsh-GetFolder fso FolderSpec))
(setq rslt (find-in-folders Folder))
(vlax-release-object Folder)
(vlax-release-object fso)
rslt
)
;; This recursive function processes each
;; folder object, and its subfolders.
(defun find-in-folders (Folder / Files SubFolders result) ;; Process files in this folder:
(setq Files (wsh-get-files Folder))
(vlax-for file files
(if (wcmatch (strcase (wsh-get-name file)) pattern)
(setq result (cons (wsh-get-path file) result))
)
(vlax-release-object file)
) (vlax-release-object files)
;; Process subfolders in this folder (recursive)
(setq SubFolders (wsh-get-SubFolders folder))
(vlax-for SubFolder SubFolders
(if Find:OnSubFolder
(Find:OnSubFolder SubFolder)
)
(setq result
(append result
(find-in-folders Subfolder)))
(vlax-release-object subfolder)
)
(vlax-release-object SubFolders)
result
)
;;;;;;;;;;;;;;;;;;;;;;;;;;; wsh.lsp ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; WSH.LSP Copyright 1999 Tony Tanzillo
;; 
;; WSH.LSP demonstrates how to use the Windows Scripting 
;; Host's FileSystemObject in Visual LISP Applications.
;; 
;; The FileSystemObject is part of Microsoft's Windows
;; Scripting Host, which is shipped with Windows 98 and
;; Internet Explorer. You can also download and install
;; the Windows Scripting Host on any NT4 or Windows 9x 
;; system by downloading it from Microsoft's web site:
;; 
;;     http://www.microsoft.com/scripting
;;     
;; The FileSystemObject
;;     
;; The FileSystemObject and its aggregates provide a 
;; well-defined, high-level ActiveX interface to the 
;; file system and its contents.
;; 
;; Within the FileSystemObject, Drives, Folders, and
;; Files are all represented by like-named ActiveX 
;; objects (Folder, File, Drive, and so on). Some of
;; those objects expose a collection property that
;; provides access to child objects.
;; 
;; For example, Drive objects have a collection of
;; Folder objects. Folder objects have a collection of 
;; File objects and SubFolder objects. You can use these 
;; objects and collections to access and process folders 
;; and files in a hierarchial fashion.
;; 
;; The following is a short synopsys of the properties
;; and methods of the top-level FileSystemObject. The
;; aggregate objects within the FileSystemObject (File,
;; Folder, Drive, and so forth) are not detailed here. 
;; You can get complete information on all child objects 
;; from the Windows Scripting Host documentation.
;; 
;; Note that the method/property/constant prefix "wsh-"
;; is VLISP-specific, as defined by the load-scripting 
;; function below.
;;   
;; Windows Scripting Host FileSystemObject
;; ---------------------------------------
;; 
;; Properties:
;; 
;; (wsh-get-Drives)
;;     
;; Methods:
;; 
;; (wsh-BuildPath <Path> <Name>)
;; (wsh-CopyFile <Source> <Destination> [<Overwrite = :vlax-true>])
;; (wsh-CopyFolder <Source> <Destination> [<Overwrite = :vlax-true>])
;; (wsh-CreateFolder <FolderName>)
;; (wsh-CreateTextFile <FileName> [<Overwrite = :vlax-false> [<Unicode = :vlax-false>]])
;; (wsh-DeleteFile <FileName> [<Force = :vlax-false>])
;; (wsh-DeleteFolder <FolderName> [<Force = :vlax-false>])
;; (wsh-DriveExists <DriveSpec>)
;; (wsh-FileExists <FileSpec>)
;; (wsh-FolderExists <FolderSpec>)
;; (wsh-GetAbsolutePathName <PathSpec>)
;; (wsh-GetBaseName <Path>)
;; (wsh-GetDrive <DriveSpec>)
;; (wsh-GetDriveName <Path>)
;; (wsh-GetExtensionName <Path>)
;; (wsh-GetFile <FileSpec>)
;; (wsh-GetFileName <PathSpec>)
;; (wsh-GetFolder <FolderSpec>)
;; (wsh-GetParentFolderName <Path>)
;; (wsh-GetSpecialFolder <FolderSpec>)
;; (wsh-GetTempName)
;; (wsh-MoveFile <Source> <Destination>)
;; (wsh-MoveFolder <Source> <Destination>)
;; (wsh-OpenTextFile <FileName> [<IOMode = :wsh-ForReading> [<Create = :vlax-false> 
;;                                                             [<Format = :wsh-TristateFalse]]])
;; 
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Global constants(setq fso:progid "Scripting.FileSystemObject")
(setq fso:prefix "wsh-");;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Utility functions
  
(defun load-scripting ( / server)
     (if (not wsh-get-drives)
           (progn
                 (vl-load-com)
                 (setq server (CoGetClassServer fso:progid))
                 (if (not server)
                       (alert "Error: Windows Scripting Host is not installed")
                       (progn
                             (vlax-import-type-library
                                   :tlb-filename Server
                                   :methods-prefix fso:prefix
                                   :properties-prefix fso:prefix
                                   :constants-prefix (strcat ":" fso:prefix)
                             )
                       )
                 )
           )
     )
)(defun ProgID->CLSID (ProgID)
     (vl-registry-read 
           (strcat "HKEY_CLASSES_ROOT\" progid "\\CLSID")
     )
)(defun CoGetClassProperty (ProgID property / clsid)
     (if (setq clsid (ProgID->CLSID ProgID))
           (vl-registry-read 
                 (strcat 
                       "HKEY_CLASSES_ROOT\\CLSID\" 
                       clsid
                       "\" property
                 )
           )
     )
)(defun CoGetClassServer (progid)
     (CoGetClassProperty progid "InprocServer32")
);; load Windows Scripting Host Type Library(load-scripting) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Windows Scripting Host FileSystemObject Example:
;;
;; Function (FindFiles <Folder> <Pattern>)
;; 
;; This function uses the FileSystemObject to
;; find all files in a given folder and all
;; subfolders that match a specified pattern.
;; 
;; It returns a list of the full filespec of
;; each file that was found, or nil if no files
;; were found.
;; 
;; Note that the pattern argument is a wcmatch-
;; style wildcard pattern, rather than a DOS
;; wildcard pattern. Hence, if you want to
;; include the period extension delimiter in the 
;; pattern, you must prefix it with ` (backquote).
;; 
;; Finally, this demonstration code is highly-
;; ineffecient, mainly due to the use of (append)
;; for constructing the resulting list. If you
;; are serious about processing large amounts of
;; files, you may want to consider optimizing it.
;; 
;; Example (find all LISP files in D:\LISP):
;; 
;;     (FindFiles "D:\\LISP" "*`.LSP")   ;; Note backquote!!!(defun FindFiles (FolderSpec Pattern / fso Folder rslt Find:OnSubFolder)     ;; If the function find-in-folders:onSubFolder is
     ;; defined, it is called and passed each folder
     ;; object that is processed. This function could
     ;; be used to keep a user informed on the progress 
     ;; of a long search operation.
     
     (defun Find:OnSubFolder (Folder)
           (princ
                 (strcat 
                       "                                                                                                             \r"
                       "Searching " (wsh-get-path folder)
                 )
           )
     )      (setq pattern (strcase pattern))
     (setq fso
           (vla-getInterfaceObject 
                 (vlax-get-acad-object)
                 "Scripting.FileSystemObject"
           )
     )   
     (setq folder (wsh-GetFolder fso FolderSpec))
     (setq rslt (find-in-folders Folder))
     (vlax-release-object Folder)
     (vlax-release-object fso)
     rslt
)
  
;; This recursive function processes each
;; folder object, and its subfolders.
  (defun find-in-folders (Folder / Files SubFolders result)     ;; Process files in this folder:
     
     (setq Files (wsh-get-files Folder))
     
     (vlax-for file files
           (if (wcmatch (strcase (wsh-get-name file)) pattern)
                 (setq result (cons (wsh-get-path file) result))
           )
           (vlax-release-object file)
     )     (vlax-release-object files)
     
     ;; Process subfolders in this folder (recursive)
     
     (setq SubFolders (wsh-get-SubFolders folder))
   
     (vlax-for SubFolder SubFolders
           (if Find:OnSubFolder
                 (Find:OnSubFolder SubFolder)
           )
           (setq result 
                 (append result 
                       (find-in-folders Subfolder)))
           (vlax-release-object subfolder)
     )
     (vlax-release-object SubFolders)
     
     result
)
;;;;;;;;;;;;;;;;;;;;;;;;;;; wsh.lsp ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

chen4 · 发表于 2004-11-29 07:42:00

没有中文注释，多有不便

龙龙仔 · 发表于 2004-11-29 12:51:00

这个以前贴过好几次 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=11083&replyID=46333&skin=1

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

VisualLISP使用Windows Scripting Host 编程的示例

浏览过的版块