[密技]：VLISP中使用 WSH操控文件和文件夹

mmmm · 发表于 2004-1-9 13:06:37

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;| Intellegent TypeLib loader
Syntax: (vlax-load-type-libeary ProgID[STRING] UniquePrefix[STR])
(vlax-load-type-libeary ProgID[STRING] PrefixList[STR])
ARG1: ProgID string same used in vlax-get-create-object function
ARG2: Can be string or a list.
List order is (:methods-prefix :properties-prefix :constants-prefix)
Description:
This function read Windows REGISTRY and try to detect the proper DLL/OCX/EXE type library
file and load the type library automatically.
Return Value:
[Success]: T
[F a i l]: NIL
|;
(Defun vlax-load-type-library
(File Prefix / FileX Host N KeyX Val OSVar rtn)
(setq Host "HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\CLSID"
N -1
KeyX (vl-registry-descendents Host)
)
(while (< (setq N (1+ N))
(length KeyX)
)
(if (and (setq Val (vl-registry-read
(strcat Host "\" (nth N KeyX) "\\ProgID")
)
)
(vl-string-search (strcase File) (strcase Val))
)
(setq FileX (vl-registry-read
(strcat Host "\" (nth N KeyX) "\\InProcServer32")
)
N (length KeyX)
)
)
)
(if (= (type Prefix) 'STR)
(setq Prefix (list Prefix Prefix (strcat ":" Prefix)))
)
(if (= (type FileX) 'LIST)
(setq FileX (cdr FileX))
)
(if (= (type FileX) 'STR)
(progn
(setq FileX (strcase FileX))
(foreach OSVar (list "SYSTEMROOT" "WINDIR"
"WINBOOTDIR" "SYSTEMDRIVE"
"USERNAME" "COMPUTERNAME"
"HOMEDRIVE" "HOMEPATH"
"PROGRAMFILES"
)
(if (vl-string-search (strcat "%" OSVar "%") FileX)
(setq FileX (vl-string-subst
(strcase (getenv OSVar))
(strcat "%" OSVar "%")
FileX
)
)
)
)
(if (setq rtn (findfile FileX))
(setq rtn
(vlax-import-type-library
:tlb-filename
FileX
:methods-prefix
(nth 0 Prefix)
:properties-prefix
(nth 1 Prefix)
:constants-prefix
(nth 2 Prefix)
)
)
)
)
)
rtn
)
;| convert all "/" in path into "\" and return all upper letters
Syntax: (vldos-formatpath PathStringToFormat[STRING])
ARG1: The path string
Description:
This function will convert all "/" in path into DOS "\".
Return Value:
[Success]: New label string
[F a i l]: None
|;
(Defun vldos-formatpath (string)
(while (vl-string-search "/" string)
(setq string (vl-string-subst "\" "/" string))
)
(while (vl-string-search "\\\" string)
(setq string (vl-string-subst "\" "\\\" string))
)
(setq string (strcase string))
string
)
;| Label the volume name of local drive
Syntax: (vldos-label DriveLetter[STRING] NewVolumnName[STRING])
ARG1: The drive letter such as "C" or "C:"
ARG2: New volumn name string, if the length of given string is bigger than 11, automatically cut
<<< Function will not check if the string is valid for a drive volume name >>>
Description:
Re-label the volume name of a certain local drive. If you are in intranet, be sure that you have enough
rights to do this via MS-DOS mode.
Return Value:
[Success]: New label string
[F a i l]: NIL
|;
(Defun vldos-Label (DRV NEW / Fil DDD ERR)
(if (> (strlen NEW) 11)
(setq NEW (substr New 1 11))
)
(if (null
(setq
Fil (vlax-get-or-create-object "Scripting.FileSystemObject")
)
)
(setq New nil)
(progn
(setq DDD (vlax-invoke-method Fil 'GetDrive DRV))
(vlax-put-property DDD "VolumeName" NEW)
(if (not (eq (setq NEW (strcase NEW))
(strcase (vlax-get-property DDD "VolumeName"))
)
)
(setq NEW nil)
)
(vlax-release-object DDD)
(vlax-release-object FIL)
)
)
NEW
)
;| Perform DOS DELTREE operation
Syntax: (vldos-deltree DirectoryToDelete[STRING])
ARG1: The directory name that to be deleted. This function will not perform an confirm interface and will
delete the folder and all the sub-folders quietly.
If the root folder is indicated, this function will automatically deltree all sub-folders in root.
Description:
Run DOS DELTREE/Y command via ActiveX. No confirm, no backup.
Return Value:
[Success]: T
[F a i l]: NIL
|;
(Defun vldos-Deltree (Folder / sf subf FIL Rtn)
(cond ((vl-file-directory-p Folder)
(if (null (setq Fil
(vlax-get-or-create-object "Scripting.FileSystemObject")
)
)
(setq Rtn nil)
(progn
(cond
((<= (strlen Folder) 3)
(if (= (strlen folder) 2)
(setq folder (strcat folder "\"))
)
(setq subf (vl-directory-files Folder nil -1)
subf (vl-remove "." subf)
subf (vl-remove ".." subf)
subf (vl-remove "Recycled" subf)
)
(foreach sf subf
(vlax-invoke-method
Fil
'DeleteFolder
(strcat folder sf)
T
)
)
)
(t (vlax-invoke-method Fil 'DeleteFolder Folder T))
)
(vlax-release-object FIL)
(setq Rtn (not (vl-file-directory-p Folder)))
)
)
)
((findfile Folder)
(vl-file-delete folder)
(setq Rtn (not (findfile Folder)))
)
)
Rtn
)
;| Create folder
Syntax: (vldos-mkdir DirectoryToCreate[STRING])
ARG1: The full path name of directory to be created. This function will automatically create all non-existing
directories in this argument.
Description:
Super tools to create nest-folders, more convinient that do in MS-DOS.
Return Value:
[Success]: Full path name string of folder created
[F a i l]: NIL
|;
(Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV)
(if (null
(setq
Fil (vlax-get-or-create-object "Scripting.FileSystemObject")
)
)
(setq Folder nil)
(progn
(while (vl-string-search "/" Folder)
(setq Folder (vl-string-subst "\" "/" Folder))
)
(if (wcmatch Folder "*\")
(setq Folder (substr Folder 1 (1- (strlen Folder))))
)
(setq FolderX Folder)
(while (setq Pos (vl-string-search "\" Folder))
(setq FFF (cons (substr Folder 1 Pos) FFF)
Folder (substr Folder (+ Pos 2))
)
)
(setq FFF (reverse (cons Folder FFF))
DRV (car FFF)
FFF (cdr FFF)
)
(foreach DIR FFF
(if
(null (vl-file-directory-p (setq DRV (strcat DRV "\" DIR)))
)
(vlax-invoke-method
Fil
'createfolder
DRV
)
)
)
(vlax-release-object Fil)
(if (setq Folder (vl-file-directory-p FolderX))
(setq Folder (vldos-formatpath FolderX))
)
)
)
Folder
)
;| Copy file or folders
Syntax: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING])
ARG1: The source file or directory to be copied.
ARG2: The destination location. If contain "*\" or "*/", this function will create a same nest-folder
name under this path while performing copy folder operation.
Description:
Copy a file or a folder.
Return Value:
[Success]: New created file or folder name string.
[F a i l]: NIL
|;
(Defun vldos-copy (from to / sys folder)
(setq from (vldos-formatpath from)
to (vldos-formatpath to)
)
(if (null (vl-file-directory-p to))
(setq to (vldos-mkdir to))
)
(if (setq sys (vlax-get-or-create-object "Shell.Application"))
(progn
(if (setq folder (vlax-invoke-method sys 'namespace to))
(progn
(princ
(strcat "\n Copying file(s) from \042"
FROM "\042 to \042"
to "\042..."
)
)
(vlax-invoke-method folder 'copyhere from (+ 4 16))
(vlax-release-object folder)
(princ "...Done!")
)
)
(vlax-release-object sys)
)
)
(princ)
)
;|(Defun vldos-copy2 (From to / rtn)
(cond
((vl-file-directory-p From)
(if (< (strlen to) 3)
(setq to (strcat to "\"))
(if (not (vl-file-directory-p to))
(vldos-mkdir to)
)
)
(if (setq
Rtn (vlax-get-or-create-object "Scripting.FileSystemObject")
)
(progn
(vlax-invoke-method Rtn 'CopyFolder From to T)
(vlax-release-object Rtn)
(if (vl-file-directory-p to)
(setq Rtn (vldos-formatpath to))
)
)
)
)
((findfile From)
(vl-file-copy From to)
(if (setq rtn (findfile to))
(setq rtn (vldos-formatpath rtn))
)
)
)
rtn
)
|;
;| Move file or folders
Syntax: (vldos-move SourceFile/Directory[STRING] TargetFile/Directory[STRING])
ARG1: The source file or directory to be moved.
ARG2: The destination location. If contain "*\" or "*/", this function will create a same nest-folder
name under this path while performing copy folder operation.
Description:
Move a file or a folder.
Return Value:
[Success]: New file or folder name path string.
[F a i l]: NIL
|;
(Defun vldos-move (from to / sys folder)
(if (setq sys (vlax-get-or-create-object "Shell.Application"))
(progn
(setq from (vldos-formatpath from)
to (vldos-formatpath to)
folder (vlax-invoke-method sys 'namespace to)
)
(if folder
(progn
(princ
(strcat "\n Moving file(s) from \042"
FROM "\042 to \042"
to "\042..."
)
)
(vlax-invoke-method folder 'movehere from (+ 4 16))
(vlax-release-object folder)
(princ "...Done!")
)
)
(vlax-release-object sys)
)
)
(princ)
)
;| Move file or folders
Syntax: (vldos-rename SourceFile/Directory[STRING] NewName[STRING])
ARG1: The source file or directory to be moved.
ARG2: The destination location. If contain "*\" or "*/", this function will create a same nest-folder
name under this path while performing copy folder operation.
Description:
Move a file or a folder.
Return Value:
[Success]: New file or folder name path string.
[F a i l]: NIL
|;
(Defun vldos-rename (From to / Fil folder new parent rtn)
(cond
((vl-file-directory-p From)
(setq parent (vl-filename-directory From)
new (strcat parent to)
)
(if (and (setq
Fil
(vlax-get-or-create-object "Scripting.FileSystemObject")
)
(> (strlen From) 3)
;;; Can not rename root folder
(null (vl-file-directory-p new))
;;; not an existing folder name
)
(progn
(setq folder (vlax-invoke-method Fil 'GetFolder From))
(vlax-put-property folder "Name" To)
(vlax-release-object folder)
(vlax-release-object Fil)
)
(setq parent nil)
)
)
((findfile From)
(setq parent (vl-filename-directory from))
(vl-file-rename From to)
)
)
(if (and parent
(vl-file-directory-p
(setq to (strcat parent to))
)
)
(setq rtn (vldos-formatpath to))
)
rtn
)
(Defun vldos-drivetype (drv / Fil drives drive typ rtn)
(setq rtn "INVALID")
(if
(and (setq
Fil (vlax-get-or-create-object "Scripting.FileSystemObject")
)
(equal :vlax-true (vlax-invoke-method Fil 'DriveExists drv))
)
(progn
(setq drives (vlax-get-property Fil 'Drives)
drive (vlax-get-property drives 'Item drv)
typ (vlax-get-property drive 'DriveType)
rtn (nth typ
(list "UNKNOWN" "REMOVABLE"
"FIXED" "REMOTE"
"CDROM" "RAMDISK"
)
)
)
(vlax-release-object drive)
(vlax-release-object drives)
(vlax-release-object Fil)
)
)
rtn
)
(Defun vldos-alldrive (/ fil drive drives lst)
(if (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject"))
(progn
(vlax-for drive (setq drives (vlax-get-property Fil 'Drives))
(setq lst (cons (vlax-get-property drive 'DriveLetter) lst))
)
(vlax-release-object drives)
(vlax-release-object Fil)
(setq lst (reverse lst))
)
)
lst
)
(Defun vldos-driveinfo (Drv Key / pos rtn)
(if (/= (type key) 'STR)
(setq rtn (vldos-alldriveinfo drv))
(if (setq pos (vl-position
(setq key (strcase key))
(list "TOTALSIZE" "FREESPACE"
"DRIVETYPE" "FILESYSTEM"
"SERIALNUMBER" "SHARENAME"
"VOLUMENAME"
)
)
)
(setq rtn (nth pos (vldos-alldriveinfo drv)))
)
)
rtn
)
(Defun vldos-alldriveinfo (Drv / DrvObj FilSys RetVal)
(if (setq
FilSys (vlax-get-or-create-object "Scripting.FileSystemObject")
)
(progn
(setq RetVal
(cond
((= (vlax-invoke FilSys "DriveExists" Drv) 0) 0)
((setq DrvObj (vlax-invoke FilSys "GetDrive" Drv))
(cond
((= (vlax-get DrvObj "IsReady") 0) -1)
((list
(/ (vlax-get-property DrvObj "TotalSize") 1000.0)
(/ (vlax-get-property DrvObj "FreeSpace") 1000.0)
(vlax-get-property DrvObj "DriveType")
(vlax-get-property DrvObj "FileSystem")
(vlax-get-property DrvObj "SerialNumber")
(vlax-get-property DrvObj "ShareName")
(vlax-get-property DrvObj "VolumeName")
)
)
)
)
)
)
(if (EQUAL (TYPE DrvObj) 'vla-object)
(vlax-release-object DrvObj)
)
(vlax-release-object FilSys)
)
)
RetVal
)
(Defun vldos-fileinfo (Drv Key / pos rtn)
(if (/= (type key) 'STR)
(setq rtn (vldos-allfileinfo drv))
(if (setq pos (vl-position
(setq key (strcase key))
(list "DATECREATED" "DATELASTMODIFIED"
"DATELASTACCESSED" "TYPE"
"SIZE" "ATTRIBUTES"
)
)
)
(setq rtn (nth pos (vldos-allfileinfo drv)))
)
)
rtn
)
(Defun vldos-allfileinfo (Fil / FilObj FilSys RetVal)
(if (setq FilSys (vlax-create-object "Scripting.FileSystemObject"))
(progn
(setq
RetVal (cond
((= (vlax-invoke FilSys "FileExists" Fil) 0) nil)
((setq FilObj (vlax-invoke FilSys "GetFile" Fil))
(list
(vlax-get FilObj "DateCreated")
(vlax-get FilObj "DateLastModified")
(vlax-get FilObj "DateLastAccessed")
(vlax-get FilObj "Type")
(vlax-get FilObj "Size")
(vlax-get FilObj "Attributes")
)
)
(T nil)
)
)
(if (= (type FilObj) 'vla-object)
(vlax-release-object FilObj)
)
(vlax-release-object FilSys)
)
)
RetVal
)
;| Read all content of a text file into a list (more fast tha AutoLISP read-line)
Syntax: (vldos-readfile FilenameToRead[STRING])
ARG1: The full path file name to be read. (contain extension)
Only text file can return good result.
Description:
Read all content of a text file and convert them into a list
Return Value:
[Success]: List contain text contents line by line
[F a i l]: NIL
|;
(Defun vldos-readfile
(Fil / string->list FilObj FilPth FilSys OpnFil All)
(Defun string->list (String / ID Rtn)
(if (null (setq ID (vl-string-search "\r\n" String)))
(setq Rtn (list String))
(progn
(while ID
(setq Rtn (cons (substr String 1 ID) Rtn)
String (substr String (+ 3 ID))
ID (vl-string-search "\r\n" String)
)
)
(setq Rtn (reverse (cons String Rtn)))
)
)
Rtn
)
(if (AND (setq FilPth (findfile Fil))
(setq FilSys (vlax-create-object "Scripting.FileSystemObject"))
)
(progn
(setq FilObj (vlax-invoke FilSys "GetFile" FilPth)
OpnFil (vlax-invoke FilObj "OpenAsTextStream" 1 0)
All (string->list (vlax-invoke OpnFil "readall"))
)
(vlax-invoke OpnFil "Close")
(vlax-release-object OpnFil)
(vlax-release-object FilObj)
(vlax-release-object FilSys)
)
)
All
)
;| Write a string list into a text file (more fast tha AutoLISP write-line)
Syntax: (vldos-writefile FileNameString[STRING] ContentStringList[LIST] ModeFlag[BOOLEAN])
(vldos-writefile FileNameString[STRING] ContentString[STRING] ModeFlag[BOOLEAN])
ARG1: The filename string
ARG2: The string or string list to write
ARG3: The append or overwrite mode flag. nil for append, T for overwrite
Description:
write a string or a string list into a file
Return Value:
[Success]: The file name string.
[F a i l]: NIL
|;
(Defun vldos-writefile
(Fil TXT Mode /
list->string FilObj FilPth
FilSys OpnFil Line
)
(Defun list->string (slist / line rtn)
(if (= (type slist) 'str)
(setq rtn slist)
(progn
(setq rtn "")
(foreach line slist
(if (= rtn "")
(setq rtn line)
(setq rtn (strcat rtn "\r\n" line))
)
)
)
)
rtn
)
(if TXT
(progn
(if (and Mode (findfile Fil))
(vl-file-delete Fil)
)
(if (setq FilSys (vlax-create-object "Scripting.FileSystemObject"))
(progn
(if (null (setq FilPth (findfile Fil)))
(setq OpnFil (vlax-invoke-method
FilSys "CreateTextFile" Fil 0 0)
)
(setq FilObj (vlax-invoke FilSys "GetFile" FilPth)
OpnFil (vlax-invoke FilObj "OpenAsTextStream" 8 0)
)
)
(if OpnFil
(progn
;;; VBA WinScript data forReading = 1, forWriting = 2, forAppending = 8;
;;; TristateUseDefault, TristateTrue, TristateFalse (-2, -1, 0)
;;;TristateUseDefault (-2) Opens the file using the system default.
;;;TristateTrue (-1) Open the file as Unicode.
;;;TristateFalse (0) Open the file as ASCII.
(vlax-invoke OpnFil "Write" (list->string TXT))
(vlax-invoke OpnFil "Close")
(vlax-release-object OpnFil)
(if (= (type FilObj) 'vla-object)
(vlax-release-object FilObj)
)
(vlax-release-object FilSys)
)
)
)
)
(if (setq Filpth (findfile Fil))
(setq FilPth (vldos-formatpath filpth))
)
)
)
filpth
)
;| Perform Windows browse folder dialog interface
Syntax: (vldos-browsedir PromptString[STRING])
(vldos-writefile NIL)
ARG1: The prompt string, if it is nil, use default prompt string of "Select Folder"
Description:
Display windows browse folder interface sna let user select a folder
Return Value:
[Success]: The selected folder path. If user pick cancel, return NIL
[F a i l]: NIL
|;
(Defun vldos-browsedir (msg / WinShell shFolder path catchit rtn)
(if (null MSG)
(setq MSG "Select folder")
)
(if (setq winshell (vlax-create-object "Shell.Application"))
(progn
(setq shFolder
(vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)
catchit
(vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(vlax-release-object shFolder)
(vlax-release-object winshell)
(if (vl-catch-all-error-p catchit)
(setq rtn nil)
(setq rtn (vldos-formatpath path))
)
)
)
rtn
)
;| Display windows type message box contain icon and multiple buttons
Syntax: (vldos-msgbox TitleString[STRING] IconType[STRING/REAL] MessageString[STRING] ButtonType[INT])
ARG1: The title string, if it is nil, use default string of "Message"
ARG2: The Icon type string or integer. If it is string, only 1st string will be checked.
ARG3: The message string, if it is nil, use default string of "Message HERE"
ARG4: Displayed button type integer.
Description:
Display windows popup message box
Return Value:
[Success]: The button flag that user picked
[F a i l]: NIL
;;;Buttons
;;;0 OK
;;;1 OK and Cancel
;;;2 Abort, Retry, and Ignore
;;;3 Yes, No, Cancel
;;;4 Yes and No
;;;5 Retry and Cancel
;;;Icon Types
;;;16 [X] Stop Mark icon
;;;32 [?] Question Mark icon
;;;48 [!] Exclamation Mark icon
;;;64 [i] Information Mark icon
;;; Return value for button picked
;;;1 OK button
;;;2 Cancel button
;;;3 Abort button
;;;4 Retry button
;;;5 Ignore button
;;;6 Yes button
;;;7 No button
|;
(Defun vldos-msgbox (TITLE ICON MSG BTNS / IDT sys BTN)
(if (setq sys (vlax-get-or-create-object "WScript.Shell"))
(progn
(if (not (equal (type TITLE) 'STR))
(setq TITLE "Message")
)
(cond ((null ICON) (setq ICON 64))
((= (type ICON) 'STR)
(setq ICON (substr (strcase ICON) 1 1)
IDT (list (cons "X" 16)
(cons "?" 32)
(cons "!" 48)
(cons "i" 64)
)
ICON (cdr (assoc ICON IDT))
)
(if (null ICON)
(setq ICON 64)
)
)
((= (type ICON) 'INT)
(if (null (member ICON (list 16 32 48 64)))
(setq ICON 64)
)
(t (setq ICON 64))
)
)
(if (not (equal (type MSG) 'STR))
(setq MSG "Message HERE")
)
(cond ((null BTNS) (setq BTNS 0))
((= (type BTNS) 'INT)
(if (or (< BTNS 0) (> BTNS 5))
(setq BTNS 0)
)
)
(t (setq BTNS 0))
)
(setq
BTN (vlax-invoke-method sys 'popup MSG 0 TITLE (+ ICON BTNS))
)
(vlax-release-object sys)
)
)
BTN
)
;| Recursively searches for instances of a file or files. The function is very similar the
command prompt's DIR /S command.
Syntax: (vldos-findfile FilenameFullPathString[STRING])
(vldos-writefile NIL)
ARG1: The desired file or files. filespec can contain wildcard characters ("*" and "?").
If filespec is not specified, all files (*.*) in the current directory and in all
subdirectories are returned.
Description:
Display windows browse folder interface sna let user select a folder
Return Value:
[Success]: A list of fully qualified filenames.
[F a i l]: NIL
|;
(Defun vldos-findfile (Filename / string->list
getallfiles allfiles path
)
(Defun string->list (String / ID Rtn)
(if (null (setq ID (vl-string-search ";" String)))
(setq Rtn (list String))
(progn
(while ID
(setq Rtn (cons (substr String 1 ID) Rtn)
String (substr String (+ 2 ID))
ID (vl-string-search ";" String)
)
)
(setq Rtn (reverse (cons String Rtn)))
)
)
Rtn
)
(Defun getallfiles (loc ext / path files rtn)
(cond
((= loc "")
(foreach path (string->list (getvar "acadprefix"))
(setq rtn (append rtn (getallfiles path ext)))
)
)
((vl-file-directory-p loc)
(if (null (wcmatch loc "*\"))
(setq loc (strcat loc "\"))
)
(foreach files (vl-directory-files loc ext)
(setq rtn (cons (vldos-formatpath (strcat loc files)) rtn))
)
(foreach path (vl-directory-files loc nil -1)
(if (and (/= path ".")
(/= path "..")
)
(setq rtn (append rtn (getallfiles (strcat loc path) ext)))
)
)
)
)
rtn
)
(setq path (vldos-formatpath (vl-filename-directory Filename))
Filename (substr Filename (1+ (strlen path)))
allfiles (acad_strlsort (getallfiles path filename))
)
allfiles
)
;| Merge 2 TEXT files
Syntax: (vldos-merge MergeBaseFilenameString[STRING] MergeFilenameString[STRING] EraseMergefileFlag[BOOLEAN])
ARG1: The base file name string
ARG2: The file that will be merged
ARG3: The flag if erase the merged file or not.
Description:
Merge two TEXT files into one file
Return Value:
[Success]: A list of fully qualified filenames.
[F a i l]: NIL
|;
(Defun vldos-merge (file1 File2 Erase / rtn)
(if (and (setq file1 (findfile file1))
(setq file2 (findfile file2))
)
(progn
(vldos-writefile file1 (vldos-readfile file2) nil)
(if Erase
(vl-file-delete File2)
)
(setq rtn (findfile file1))
)
)
rtn
)
;| Display a HTML file (source codes) or some string in a MS IE window, calling from VLISP
Syntax: (vldos-text->ie ContentString[STRING])
ARG1: The string or string list to be displayed in IE Window
Description:
Calling within Visual LISP, send string data into a new MS IE window
Return Value:
[Success]: The MS IE window with string(s)
[F a i l]: NIL
|;
(Defun vldos-text->ie (TXT / list->string ie ln doc)
(if (= (type TXT) 'STR)
(setq TXT (list TXT))
)
(if (setq ie (vlax-create-object "InternetExplorer.Application"))
(progn
(vlax-put-property ie 'menubar 0)
(vlax-put-property ie 'toolbar 0)
(vla-put-visible ie t)
(vlax-invoke-method ie 'navigate "about:blank")
(setq doc (vlax-get-property ie 'document))
(foreach ln TXT
(vlax-invoke-method doc 'writeln ln "")
)
(vlax-invoke-method doc 'close)
(vlax-release-object doc)
(vlax-release-object ie)
)
)
)
;| call the windows date/time setting dialog from VLISP
Syntax: (vldos-time)
Description:
Calling within Visual LISP, display the windows date/time setting window
Return Value:
[Success]: The windows date/time setting window
[F a i l]: NIL
|;
(Defun vldos-time (/ sys)
(if (setq sys (vlax-get-or-create-object "Shell.Application"))
(progn
(vlax-invoke-method sys 'settime)
(vlax-release-object sys)
)
)
)

;|  Intellegent TypeLib loader 
Syntax: (vlax-load-type-libeary ProgID[STRING] UniquePrefix[STR]) 
        (vlax-load-type-libeary ProgID[STRING] PrefixList[STR]) 
  ARG1: ProgID string same used in vlax-get-create-object function 
  ARG2: Can be string or a list. 
        List order is (:methods-prefix :properties-prefix :constants-prefix) 
Description: 
    This function read Windows REGISTRY and try to detect the proper DLL/OCX/EXE type library 
file and load the type library automatically. 
Return Value: 
[Success]: T 
[F a i l]: NIL 
|; 
(Defun vlax-load-type-library 
       (File Prefix / FileX Host N KeyX Val OSVar rtn) 
  (setq        Host "HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\CLSID" 
        N    -1 
        KeyX (vl-registry-descendents Host) 
  ) 
  (while (< (setq N (1+ N)) 
            (length KeyX) 
         ) 
    (if        (and (setq Val (vl-registry-read 
                         (strcat Host "\" (nth N KeyX) "\\ProgID") 
                       ) 
             ) 
             (vl-string-search (strcase File) (strcase Val)) 
        ) 
      (setq FileX (vl-registry-read 
                    (strcat Host "\" (nth N KeyX) "\\InProcServer32") 
                  ) 
            N          (length KeyX) 
      ) 
    ) 
  ) 
  (if (= (type Prefix) 'STR) 
    (setq Prefix (list Prefix Prefix (strcat ":" Prefix))) 
  ) 
  (if (= (type FileX) 'LIST) 
    (setq FileX (cdr FileX)) 
  ) 
  (if (= (type FileX) 'STR) 
    (progn 
      (setq FileX (strcase FileX)) 
      (foreach OSVar (list "SYSTEMROOT"             "WINDIR" 
                           "WINBOOTDIR"             "SYSTEMDRIVE" 
                           "USERNAME"             "COMPUTERNAME" 
                           "HOMEDRIVE"             "HOMEPATH" 
                           "PROGRAMFILES" 
                          ) 
        (if (vl-string-search (strcat "%" OSVar "%") FileX) 
          (setq        FileX (vl-string-subst 
                        (strcase (getenv OSVar)) 
                        (strcat "%" OSVar "%") 
                        FileX 
                      ) 
          ) 
        ) 
      ) 
      (if (setq rtn (findfile FileX)) 
        (setq rtn 
               (vlax-import-type-library 
                 :tlb-filename 
                 FileX 
                 :methods-prefix 
                 (nth 0 Prefix) 
                 :properties-prefix 
                 (nth 1 Prefix) 
                 :constants-prefix 
                 (nth 2 Prefix) 
               ) 
        ) 
      ) 
    ) 
  ) 
  rtn 
) 
 ;|  convert all "/" in path into "\" and return all upper letters 
Syntax: (vldos-formatpath PathStringToFormat[STRING]) 
  ARG1: The path string 
Description: 
    This function will convert all "/" in path into DOS "\". 
Return Value: 
[Success]: New label string 
[F a i l]: None 
|; 
(Defun vldos-formatpath        (string) 
  (while (vl-string-search "/" string) 
    (setq string (vl-string-subst "\" "/" string)) 
  ) 
  (while (vl-string-search "\\\" string) 
    (setq string (vl-string-subst "\" "\\\" string)) 
  ) 
  (setq string (strcase string)) 
  string 
) 
 ;|  Label the volume name of local drive 
Syntax: (vldos-label DriveLetter[STRING] NewVolumnName[STRING]) 
  ARG1: The drive letter such as "C" or "C:" 
  ARG2: New volumn name string, if the length of given string is bigger than 11, automatically cut 
        <<< Function will not check if the string is valid for a drive volume name >>> 
Description: 
    Re-label the volume name of a certain local drive. If you are in intranet, be sure that you have enough 
rights to do this via MS-DOS mode. 
Return Value: 
[Success]: New label string 
[F a i l]: NIL 
|; 
(Defun vldos-Label (DRV NEW / Fil DDD ERR) 
  (if (> (strlen NEW) 11) 
    (setq NEW (substr New 1 11)) 
  ) 
  (if (null 
        (setq 
          Fil (vlax-get-or-create-object "Scripting.FileSystemObject") 
        ) 
      ) 
    (setq New nil) 
    (progn 
      (setq DDD (vlax-invoke-method Fil 'GetDrive DRV)) 
      (vlax-put-property DDD "VolumeName" NEW) 
      (if (not (eq (setq NEW (strcase NEW)) 
                   (strcase (vlax-get-property DDD "VolumeName")) 
               ) 
          ) 
        (setq NEW nil) 
      ) 
      (vlax-release-object DDD) 
      (vlax-release-object FIL) 
    ) 
  ) 
  NEW 
) 
 ;|  Perform DOS DELTREE operation 
Syntax: (vldos-deltree DirectoryToDelete[STRING]) 
  ARG1: The directory name that to be deleted. This function will not perform an confirm interface and will 
        delete the folder and all the sub-folders quietly. 
        If the root folder is indicated, this function will automatically deltree all sub-folders in root. 
Description: 
    Run DOS DELTREE/Y command via ActiveX. No confirm, no backup. 
    Return Value: 
[Success]: T 
[F a i l]: NIL 
|; 
(Defun vldos-Deltree (Folder / sf subf FIL Rtn) 
  (cond        ((vl-file-directory-p Folder) 
         (if (null (setq Fil 
                          (vlax-get-or-create-object "Scripting.FileSystemObject") 
                   ) 
             ) 
           (setq Rtn nil) 
           (progn 
             (cond 
               ((<= (strlen Folder) 3) 
                (if (= (strlen folder) 2) 
                  (setq folder (strcat folder "\")) 
                ) 
                (setq subf (vl-directory-files Folder nil -1) 
                      subf (vl-remove "." subf) 
                      subf (vl-remove ".." subf) 
                      subf (vl-remove "Recycled" subf) 
                ) 
                (foreach sf subf 
                  (vlax-invoke-method 
                    Fil 
                    'DeleteFolder 
                    (strcat folder sf) 
                    T 
                  ) 
                ) 
               ) 
               (t (vlax-invoke-method Fil 'DeleteFolder Folder T)) 
             ) 
             (vlax-release-object FIL) 
             (setq Rtn (not (vl-file-directory-p Folder))) 
           ) 
         ) 
        ) 
        ((findfile Folder) 
         (vl-file-delete folder) 
         (setq Rtn (not (findfile Folder))) 
        ) 
  ) 
  Rtn 
) 
 ;|  Create folder 
Syntax: (vldos-mkdir DirectoryToCreate[STRING]) 
  ARG1: The full path name of directory to be created. This function will automatically create all non-existing 
        directories in this argument. 
Description: 
    Super tools to create nest-folders, more convinient that do in MS-DOS. 
Return Value: 
[Success]: Full path name string of folder created 
[F a i l]: NIL 
|; 
(Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV) 
  (if (null 
        (setq 
          Fil (vlax-get-or-create-object "Scripting.FileSystemObject") 
        ) 
      ) 
    (setq Folder nil) 
    (progn 
      (while (vl-string-search "/" Folder) 
        (setq Folder (vl-string-subst "\" "/" Folder)) 
      ) 
      (if (wcmatch Folder "*\") 
        (setq Folder (substr Folder 1 (1- (strlen Folder)))) 
      ) 
      (setq FolderX Folder) 
      (while (setq Pos (vl-string-search "\" Folder)) 
        (setq FFF    (cons (substr Folder 1 Pos) FFF) 
              Folder (substr Folder (+ Pos 2)) 
        ) 
      ) 
      (setq FFF        (reverse (cons Folder FFF)) 
            DRV        (car FFF) 
            FFF        (cdr FFF) 
      ) 
      (foreach DIR FFF 
        (if 
          (null        (vl-file-directory-p (setq DRV (strcat DRV "\" DIR))) 
          ) 
           (vlax-invoke-method 
             Fil 
             'createfolder 
             DRV 
           ) 
        ) 
      ) 
      (vlax-release-object Fil) 
      (if (setq Folder (vl-file-directory-p FolderX)) 
        (setq Folder (vldos-formatpath FolderX)) 
      ) 
    ) 
  ) 
  Folder 
) 
 ;|  Copy file or folders 
Syntax: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING]) 
  ARG1: The source file or directory to be copied. 
  ARG2: The destination location. If contain "*\" or "*/", this function will create a same nest-folder 
        name under this path while performing copy folder operation. 
Description: 
    Copy a file or a folder. 
Return Value: 
[Success]: New created file or folder name string. 
[F a i l]: NIL 
|; 
(Defun vldos-copy (from to / sys folder) 
  (setq        from (vldos-formatpath from) 
        to   (vldos-formatpath to) 
  ) 
  (if (null (vl-file-directory-p to)) 
    (setq to (vldos-mkdir to)) 
  ) 
  (if (setq sys (vlax-get-or-create-object "Shell.Application")) 
    (progn 
      (if (setq folder (vlax-invoke-method sys 'namespace to)) 
        (progn 
          (princ 
            (strcat "\n Copying file(s) from \042" 
                    FROM                   "\042 to \042" 
                    to                           "\042..." 
                   ) 
          ) 
          (vlax-invoke-method folder 'copyhere from (+ 4 16)) 
          (vlax-release-object folder) 
          (princ "...Done!") 
        ) 
      ) 
      (vlax-release-object sys) 
    ) 
  ) 
  (princ) 
) 
 ;|(Defun vldos-copy2 (From to / rtn) 
  (cond 
    ((vl-file-directory-p From) 
     (if (< (strlen to) 3) 
       (setq to (strcat to "\")) 
       (if (not (vl-file-directory-p to)) 
         (vldos-mkdir to) 
       ) 
     ) 
     (if (setq 
           Rtn (vlax-get-or-create-object "Scripting.FileSystemObject") 
         ) 
       (progn 
         (vlax-invoke-method Rtn 'CopyFolder From to T) 
         (vlax-release-object Rtn) 
         (if (vl-file-directory-p to) 
           (setq Rtn (vldos-formatpath to)) 
         ) 
       ) 
     ) 
    ) 
    ((findfile From) 
     (vl-file-copy From to) 
     (if (setq rtn (findfile to)) 
       (setq rtn (vldos-formatpath rtn)) 
     ) 
    ) 
  ) 
  rtn 
) 
|; 
 ;|  Move file or folders 
Syntax: (vldos-move SourceFile/Directory[STRING] TargetFile/Directory[STRING]) 
  ARG1: The source file or directory to be moved. 
  ARG2: The destination location. If contain "*\" or "*/", this function will create a same nest-folder 
        name under this path while performing copy folder operation. 
Description: 
    Move a file or a folder. 
Return Value: 
[Success]: New file or folder name path string. 
[F a i l]: NIL 
|; 
(Defun vldos-move (from to / sys folder) 
  (if (setq sys (vlax-get-or-create-object "Shell.Application")) 
    (progn 
      (setq from   (vldos-formatpath from) 
            to           (vldos-formatpath to) 
            folder (vlax-invoke-method sys 'namespace to) 
      ) 
      (if folder 
        (progn 
          (princ 
            (strcat "\n Moving file(s) from \042" 
                    FROM                   "\042 to \042" 
                    to                           "\042..." 
                   ) 
          ) 
          (vlax-invoke-method folder 'movehere from (+ 4 16)) 
          (vlax-release-object folder) 
          (princ "...Done!") 
        ) 
      ) 
      (vlax-release-object sys) 
    ) 
  ) 
  (princ) 
) 
 ;|  Move file or folders 
Syntax: (vldos-rename SourceFile/Directory[STRING] NewName[STRING]) 
  ARG1: The source file or directory to be moved. 
  ARG2: The destination location. If contain "*\" or "*/", this function will create a same nest-folder 
        name under this path while performing copy folder operation. 
Description: 
    Move a file or a folder. 
Return Value: 
[Success]: New file or folder name path string. 
[F a i l]: NIL 
|; 
(Defun vldos-rename (From to / Fil folder new parent rtn) 
  (cond 
    ((vl-file-directory-p From) 
     (setq parent (vl-filename-directory From) 
           new          (strcat parent to) 
     ) 
     (if (and (setq 
                Fil 
                 (vlax-get-or-create-object "Scripting.FileSystemObject") 
              ) 
              (> (strlen From) 3) 
;;; Can not rename root folder 
              (null (vl-file-directory-p new)) 
;;; not an existing folder name 
         ) 
       (progn 
         (setq folder (vlax-invoke-method Fil 'GetFolder From)) 
         (vlax-put-property folder "Name" To) 
         (vlax-release-object folder) 
         (vlax-release-object Fil) 
       ) 
       (setq parent nil) 
     ) 
    ) 
    ((findfile From) 
     (setq parent (vl-filename-directory from)) 
     (vl-file-rename From to) 
    ) 
  ) 
  (if (and parent 
           (vl-file-directory-p 
             (setq to (strcat parent to)) 
           ) 
      ) 
    (setq rtn (vldos-formatpath to)) 
  ) 
  rtn 
) 
(Defun vldos-drivetype (drv / Fil drives drive typ rtn) 
  (setq rtn "INVALID") 
  (if 
    (and (setq 
           Fil (vlax-get-or-create-object "Scripting.FileSystemObject") 
         ) 
         (equal :vlax-true (vlax-invoke-method Fil 'DriveExists drv)) 
    ) 
     (progn 
       (setq drives (vlax-get-property Fil 'Drives) 
             drive  (vlax-get-property drives 'Item drv) 
             typ    (vlax-get-property drive 'DriveType) 
             rtn    (nth typ 
                         (list "UNKNOWN"     "REMOVABLE" 
                               "FIXED"             "REMOTE" 
                               "CDROM"             "RAMDISK" 
                              ) 
                    ) 
       ) 
       (vlax-release-object drive) 
       (vlax-release-object drives) 
       (vlax-release-object Fil) 
     ) 
  ) 
  rtn 
) 
(Defun vldos-alldrive (/ fil drive drives lst) 
  (if (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject")) 
    (progn 
      (vlax-for        drive (setq drives (vlax-get-property Fil 'Drives)) 
        (setq lst (cons (vlax-get-property drive 'DriveLetter) lst)) 
      ) 
      (vlax-release-object drives) 
      (vlax-release-object Fil) 
      (setq lst (reverse lst)) 
    ) 
  ) 
  lst 
) 
(Defun vldos-driveinfo (Drv Key / pos rtn) 
  (if (/= (type key) 'STR) 
    (setq rtn (vldos-alldriveinfo drv)) 
    (if        (setq pos (vl-position 
                    (setq key (strcase key)) 
                    (list "TOTALSIZE"            "FREESPACE" 
                          "DRIVETYPE"            "FILESYSTEM" 
                          "SERIALNUMBER"    "SHARENAME" 
                          "VOLUMENAME" 
                         ) 
                  ) 
        ) 
      (setq rtn (nth pos (vldos-alldriveinfo drv))) 
    ) 
  ) 
  rtn 
) 
(Defun vldos-alldriveinfo (Drv / DrvObj FilSys RetVal) 
  (if (setq 
        FilSys (vlax-get-or-create-object "Scripting.FileSystemObject") 
      ) 
    (progn 
      (setq RetVal 
             (cond 
               ((= (vlax-invoke FilSys "DriveExists" Drv) 0) 0) 
               ((setq DrvObj (vlax-invoke FilSys "GetDrive" Drv)) 
                (cond 
                  ((= (vlax-get DrvObj "IsReady") 0) -1) 
                  ((list 
                     (/ (vlax-get-property DrvObj "TotalSize") 1000.0) 
                     (/ (vlax-get-property DrvObj "FreeSpace") 1000.0) 
                     (vlax-get-property DrvObj "DriveType") 
                     (vlax-get-property DrvObj "FileSystem") 
                     (vlax-get-property DrvObj "SerialNumber") 
                     (vlax-get-property DrvObj "ShareName") 
                     (vlax-get-property DrvObj "VolumeName") 
                   ) 
                  ) 
                ) 
               ) 
             ) 
      ) 
      (if (EQUAL (TYPE DrvObj) 'vla-object) 
        (vlax-release-object DrvObj) 
      ) 
      (vlax-release-object FilSys) 
    ) 
  ) 
  RetVal 
) 
(Defun vldos-fileinfo (Drv Key / pos rtn) 
  (if (/= (type key) 'STR) 
    (setq rtn (vldos-allfileinfo drv)) 
    (if        (setq pos (vl-position 
                    (setq key (strcase key)) 
                    (list "DATECREATED"              "DATELASTMODIFIED" 
                          "DATELASTACCESSED"  "TYPE" 
                          "SIZE"              "ATTRIBUTES" 
                         ) 
                  ) 
        ) 
      (setq rtn (nth pos (vldos-allfileinfo drv))) 
    ) 
  ) 
  rtn 
) 
(Defun vldos-allfileinfo (Fil / FilObj FilSys RetVal) 
  (if (setq FilSys (vlax-create-object "Scripting.FileSystemObject")) 
    (progn 
      (setq 
        RetVal (cond 
                 ((= (vlax-invoke FilSys "FileExists" Fil) 0) nil) 
                 ((setq FilObj (vlax-invoke FilSys "GetFile" Fil)) 
                  (list 
                    (vlax-get FilObj "DateCreated") 
                    (vlax-get FilObj "DateLastModified") 
                    (vlax-get FilObj "DateLastAccessed") 
                    (vlax-get FilObj "Type") 
                    (vlax-get FilObj "Size") 
                    (vlax-get FilObj "Attributes") 
                  ) 
                 ) 
                 (T nil) 
               ) 
      ) 
      (if (= (type FilObj) 'vla-object) 
        (vlax-release-object FilObj) 
      ) 
      (vlax-release-object FilSys) 
    ) 
  ) 
  RetVal 
) 
 ;|  Read all content of a text file into a list (more fast tha AutoLISP read-line) 
Syntax: (vldos-readfile FilenameToRead[STRING]) 
  ARG1: The full path file name to be read. (contain extension) 
        Only text file can return good result. 
Description: 
    Read all content of a text file and convert them into a list 
Return Value: 
[Success]: List contain text contents line by line 
[F a i l]: NIL 
|; 
(Defun vldos-readfile 
       (Fil / string->list FilObj FilPth FilSys OpnFil All) 
  (Defun string->list (String / ID Rtn) 
    (if        (null (setq ID (vl-string-search "\r\n" String))) 
      (setq Rtn (list String)) 
      (progn 
        (while ID 
          (setq        Rtn    (cons (substr String 1 ID) Rtn) 
                String (substr String (+ 3 ID)) 
                ID     (vl-string-search "\r\n" String) 
          ) 
        ) 
        (setq Rtn (reverse (cons String Rtn))) 
      ) 
    ) 
    Rtn 
  ) 
  (if (AND (setq FilPth (findfile Fil)) 
           (setq FilSys (vlax-create-object "Scripting.FileSystemObject")) 
      ) 
    (progn 
      (setq FilObj (vlax-invoke FilSys "GetFile" FilPth) 
            OpnFil (vlax-invoke FilObj "OpenAsTextStream" 1 0) 
            All           (string->list (vlax-invoke OpnFil "readall")) 
      ) 
      (vlax-invoke OpnFil "Close") 
      (vlax-release-object OpnFil) 
      (vlax-release-object FilObj) 
      (vlax-release-object FilSys) 
    ) 
  ) 
  All 
) 
 ;|  Write a string list into a text file (more fast tha AutoLISP write-line) 
Syntax: (vldos-writefile FileNameString[STRING] ContentStringList[LIST] ModeFlag[BOOLEAN]) 
        (vldos-writefile FileNameString[STRING] ContentString[STRING] ModeFlag[BOOLEAN]) 
  ARG1: The filename string 
  ARG2: The string or string list to write 
  ARG3: The append or overwrite mode flag. nil for append, T for overwrite 
Description: 
    write a string or a string list into a file 
Return Value: 
[Success]: The file name string. 
[F a i l]: NIL 
|; 
(Defun vldos-writefile 
                       (Fil          TXT            Mode      / 
                        list->string            FilObj    FilPth 
                        FilSys          OpnFil    Line 
                       ) 
  (Defun list->string (slist / line rtn) 
    (if        (= (type slist) 'str) 
      (setq rtn slist) 
      (progn 
        (setq rtn "") 
        (foreach line slist 
          (if (= rtn "") 
            (setq rtn line) 
            (setq rtn (strcat rtn "\r\n" line)) 
          ) 
        ) 
      ) 
    ) 
    rtn 
  ) 
  (if TXT 
    (progn 
      (if (and Mode (findfile Fil)) 
        (vl-file-delete Fil) 
      ) 
      (if (setq FilSys (vlax-create-object "Scripting.FileSystemObject")) 
        (progn 
          (if (null (setq FilPth (findfile Fil))) 
            (setq OpnFil (vlax-invoke-method 
                           FilSys "CreateTextFile" Fil 0 0) 
            ) 
            (setq FilObj (vlax-invoke FilSys "GetFile" FilPth) 
                  OpnFil (vlax-invoke FilObj "OpenAsTextStream" 8 0) 
            ) 
          ) 
          (if OpnFil 
            (progn 
;;; VBA WinScript data forReading = 1, forWriting = 2, forAppending = 8; 
;;; TristateUseDefault, TristateTrue, TristateFalse (-2, -1, 0) 
;;;TristateUseDefault (-2) Opens the file using the system default. 
;;;TristateTrue (-1) Open the file as Unicode. 
;;;TristateFalse (0) Open the file as ASCII. 
              (vlax-invoke OpnFil "Write" (list->string TXT)) 
              (vlax-invoke OpnFil "Close") 
              (vlax-release-object OpnFil) 
              (if (= (type FilObj) 'vla-object) 
                (vlax-release-object FilObj) 
              ) 
              (vlax-release-object FilSys) 
            ) 
          ) 
        ) 
      ) 
      (if (setq Filpth (findfile Fil)) 
        (setq FilPth (vldos-formatpath filpth)) 
      ) 
    ) 
  ) 
  filpth 
) 
 ;|  Perform Windows browse folder dialog interface 
Syntax: (vldos-browsedir PromptString[STRING]) 
        (vldos-writefile NIL) 
  ARG1: The prompt string, if it is nil, use default prompt string of "Select Folder" 
Description: 
    Display windows browse folder interface sna let user select a folder 
Return Value: 
[Success]: The selected folder path. If user pick cancel, return NIL 
[F a i l]: NIL 
|; 
(Defun vldos-browsedir (msg / WinShell shFolder path catchit rtn) 
  (if (null MSG) 
    (setq MSG "Select folder") 
  ) 
  (if (setq winshell (vlax-create-object "Shell.Application")) 
    (progn 
      (setq shFolder 
                     (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1) 
            catchit 
                     (vl-catch-all-apply 
                       '(lambda        () 
                          (setq shFolder (vlax-get-property shFolder 'self)) 
                          (setq path (vlax-get-property shFolder 'path)) 
                        ) 
                     ) 
      ) 
      (vlax-release-object shFolder) 
      (vlax-release-object winshell) 
      (if (vl-catch-all-error-p catchit) 
        (setq rtn nil) 
        (setq rtn (vldos-formatpath path)) 
      ) 
    ) 
  ) 
  rtn 
) 
 ;|  Display windows type message box contain icon and multiple buttons 
Syntax: (vldos-msgbox TitleString[STRING] IconType[STRING/REAL] MessageString[STRING] ButtonType[INT]) 
  ARG1: The title string, if it is nil, use default string of "Message" 
  ARG2: The Icon type string or integer. If it is string, only 1st string will be checked. 
  ARG3: The message string, if it is nil, use default string of "Message HERE" 
  ARG4: Displayed button type integer. 
Description: 
    Display windows popup message box 
Return Value: 
[Success]: The button flag that user picked 
[F a i l]: NIL 
;;;Buttons 
;;;0  OK 
;;;1  OK and Cancel 
;;;2  Abort, Retry, and Ignore 
;;;3  Yes, No, Cancel 
;;;4  Yes and No 
;;;5  Retry and Cancel 
;;;Icon Types 
;;;16 [X] Stop Mark icon 
;;;32 [?] Question Mark icon 
;;;48 [!] Exclamation Mark icon 
;;;64 [i] Information Mark icon 
;;; Return value for button picked 
;;;1  OK button 
;;;2  Cancel button 
;;;3  Abort button 
;;;4  Retry button 
;;;5  Ignore button 
;;;6  Yes button 
;;;7  No button 
|; 
(Defun vldos-msgbox (TITLE ICON MSG BTNS / IDT sys BTN) 
  (if (setq sys (vlax-get-or-create-object "WScript.Shell")) 
    (progn 
      (if (not (equal (type TITLE) 'STR)) 
        (setq TITLE "Message") 
      ) 
      (cond ((null ICON) (setq ICON 64)) 
            ((= (type ICON) 'STR) 
             (setq ICON        (substr (strcase ICON) 1 1) 
                   IDT        (list (cons "X" 16) 
                              (cons "?" 32) 
                              (cons "!" 48) 
                              (cons "i" 64) 
                        ) 
                   ICON        (cdr (assoc ICON IDT)) 
             ) 
             (if (null ICON) 
               (setq ICON 64) 
             ) 
            ) 
            ((= (type ICON) 'INT) 
             (if (null (member ICON (list 16 32 48 64))) 
               (setq ICON 64) 
             ) 
             (t (setq ICON 64)) 
            ) 
      ) 
      (if (not (equal (type MSG) 'STR)) 
        (setq MSG "Message HERE") 
      ) 
      (cond ((null BTNS) (setq BTNS 0)) 
            ((= (type BTNS) 'INT) 
             (if (or (< BTNS 0) (> BTNS 5)) 
               (setq BTNS 0) 
             ) 
            ) 
            (t (setq BTNS 0)) 
      ) 
      (setq 
        BTN (vlax-invoke-method sys 'popup MSG 0 TITLE (+ ICON BTNS)) 
      ) 
      (vlax-release-object sys) 
    ) 
  ) 
  BTN 
) 
 ;|  Recursively searches for instances of a file or files. The function is very similar the 
     command prompt's DIR /S command. 
Syntax: (vldos-findfile FilenameFullPathString[STRING]) 
        (vldos-writefile NIL) 
  ARG1: The desired file or files. filespec can contain wildcard characters ("*" and "?"). 
        If filespec is not specified, all files (*.*) in the current directory and in all 
        subdirectories are returned. 
Description: 
    Display windows browse folder interface sna let user select a folder 
Return Value: 
[Success]: A list of fully qualified filenames. 
[F a i l]: NIL 
|; 
(Defun vldos-findfile (Filename            /                 string->list 
                       getallfiles  allfiles         path 
                      ) 
  (Defun string->list (String / ID Rtn) 
    (if        (null (setq ID (vl-string-search ";" String))) 
      (setq Rtn (list String)) 
      (progn 
        (while ID 
          (setq        Rtn    (cons (substr String 1 ID) Rtn) 
                String (substr String (+ 2 ID)) 
                ID     (vl-string-search ";" String) 
          ) 
        ) 
        (setq Rtn (reverse (cons String Rtn))) 
      ) 
    ) 
    Rtn 
  ) 
  (Defun getallfiles (loc ext / path files rtn) 
    (cond 
      ((= loc "") 
       (foreach        path (string->list (getvar "acadprefix")) 
         (setq rtn (append rtn (getallfiles path ext))) 
       ) 
      ) 
      ((vl-file-directory-p loc) 
       (if (null (wcmatch loc "*\")) 
         (setq loc (strcat loc "\")) 
       ) 
       (foreach        files (vl-directory-files loc ext) 
         (setq rtn (cons (vldos-formatpath (strcat loc files)) rtn)) 
       ) 
       (foreach        path (vl-directory-files loc nil -1) 
         (if (and (/= path ".") 
                  (/= path "..") 
             ) 
           (setq rtn (append rtn (getallfiles (strcat loc path) ext))) 
         ) 
       ) 
      ) 
    ) 
    rtn 
  ) 
  (setq        path         (vldos-formatpath (vl-filename-directory Filename)) 
        Filename (substr Filename (1+ (strlen path))) 
        allfiles (acad_strlsort (getallfiles path filename)) 
  ) 
  allfiles 
) 
 ;| Merge 2 TEXT files 
Syntax: (vldos-merge MergeBaseFilenameString[STRING] MergeFilenameString[STRING] EraseMergefileFlag[BOOLEAN]) 
  ARG1: The base file name string 
  ARG2: The file that will be merged 
  ARG3: The flag if erase the merged file or not. 
Description: 
    Merge two TEXT files into one file 
Return Value: 
[Success]: A list of fully qualified filenames. 
[F a i l]: NIL 
|; 
(Defun vldos-merge (file1 File2 Erase / rtn) 
  (if (and (setq file1 (findfile file1)) 
           (setq file2 (findfile file2)) 
      ) 
    (progn 
      (vldos-writefile file1 (vldos-readfile file2) nil) 
      (if Erase 
        (vl-file-delete File2) 
      ) 
      (setq rtn (findfile file1)) 
    ) 
  ) 
  rtn 
) 
 ;| Display a HTML file (source codes) or some string in a MS IE window, calling from VLISP 
Syntax: (vldos-text->ie ContentString[STRING]) 
  ARG1: The string or string list to be displayed in IE Window 
Description: 
    Calling within Visual LISP, send string data into a new MS IE window 
Return Value: 
[Success]: The MS IE window with string(s) 
[F a i l]: NIL 
|; 
(Defun vldos-text->ie (TXT / list->string ie ln doc) 
  (if (= (type TXT) 'STR) 
    (setq TXT (list TXT)) 
  ) 
  (if (setq ie (vlax-create-object "InternetExplorer.Application")) 
    (progn 
      (vlax-put-property ie 'menubar 0) 
      (vlax-put-property ie 'toolbar 0) 
      (vla-put-visible ie t) 
      (vlax-invoke-method ie 'navigate "about:blank") 
      (setq doc (vlax-get-property ie 'document)) 
      (foreach ln TXT 
        (vlax-invoke-method doc 'writeln ln "") 
      ) 
      (vlax-invoke-method doc 'close) 
      (vlax-release-object doc) 
      (vlax-release-object ie) 
    ) 
  ) 
) 
 ;| call the windows date/time setting dialog from VLISP 
Syntax: (vldos-time) 
Description: 
    Calling within Visual LISP, display the windows date/time setting window 
Return Value: 
[Success]: The windows date/time setting window 
[F a i l]: NIL 
|; 
(Defun vldos-time (/ sys) 
  (if (setq sys (vlax-get-or-create-object "Shell.Application")) 
    (progn 
      (vlax-invoke-method sys 'settime) 
      (vlax-release-object sys) 
    ) 
  ) 
)

aeo · 发表于 2004-1-9 23:23:23

加分了,
不过我没细看,有一部分秋峰贴过.
其实只要找一下"Scripting.FileSystemObject"的方法，基本就可以写出来了.

zhang8755 · 发表于 2004-1-11 19:57:01

像楼上说的"Scripting.FileSystemObject"方法的帮助在哪能找到，或者介绍一下什么书中有相关的介绍，还有类似的，比如系统共用对话框（文件打开、目录浏览等等）在vlisp中如何使用？

mmmm · 发表于 2004-1-12 13:22:42

可以在WindowxXP系统的
C:\Program Files\Microsoft Visual Studio\Common\IDE\IDE98\MSE\2052
中找到
VBSCRIP5.CHM
ASP.CHM
JSCRIPT5.CHM

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

[密技]：VLISP中使用 WSH操控文件和文件夹

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

相关帖子