[推荐]：我翻译整理的VLISP磁盘操作函数

zhang8755 · 发表于 2004-7-4 10:39:06

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

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

×

VLISP磁盘操作函数，通过ACTIVEX接口

[FONT=courier new]
;| 类型库智能化加载
用法: (vlax-load-type-libeary ProgID[STRING] UniquePrefix[STR])
(vlax-load-type-libeary ProgID[STRING] PrefixList[STR])
参数1: 与vlax-get-create-object 函数相同的ProgID 字符串
参数2: 前缀，可以是字符串或表
表的顺序 (:methods-prefix :properties-prefix :constants-prefix)
说明:
此函数读取 Windows REGISTRY 并且侦测合适的 DLL/OCX/EXE 类型库并自动加载
返回值:
[成功]: T
[失败]: 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
)
;| 转换路径中字符 "/" 为 "\" 并返回大写值
用法: (vldos-formatpath PathStringToFormat[STRING])
参数1: 路径字符串
说明:
此函数转换字符 "/" 为 "\".
返回值:
[成功]: 转换后的字符串
[失败]: 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
)
;| 修改本地磁盘的卷标
用法: (vldos-label DriveLetter[STRING] NewVolumnName[STRING])
参数1: 盘符例如: "C" 或 "C:"
参数2: 新卷标, 如果长度超过11个字符, 自动裁掉
<<< 本函数不检查字符串是否符合命名规则 >>>
说明:
修改本地磁盘的卷标. 确保具有相应的权限进行此操作
返回值:
[成功]: 新卷标
[失败]: 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
)
;| 执行 DOS DELTREE 命令
用法: (vldos-deltree DirectoryToDelete[STRING])
参数1: 要被删除的目录名称. 此函数不显示确认过程，删除文件夹和所有的子文件夹
如果参数是根目录，江删除所有的子目录.
说明:
通过 ActiveX 执行 DOS DELTREE/Y 命令. 无需确认，无备份.
返回值:
[成功]: T
[失败]: 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
)
;| 创建目录
用法: (vldos-mkdir DirectoryToCreate[STRING])
参数1: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录.
说明:
可创建多层目录.
返回值:
[成功]: 创建目录的全路径名
[失败]: 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
)
;| 复制文件或目录
用法: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING])
参数1: 源文件或目录
参数2: 目标目录. 如果包含 "*\" or "*/", 此函数将在此路径下创建相同的子目录.
说明:
复制文件或目录.
返回值:
[成功]: 复制的文件或目录字符串.
[失败]: 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
)
|;
;| 移动文件或目录
用法: (vldos-move SourceFile/Directory[STRING] TargetFile/Directory[STRING])
参数1: 源文件或目录.
参数2: 目标目录. 如果包含 "*\" or "*/", 此函数将在此路径下创建相同的子目录.
说明:
移动文件或目录.
返回值:
[成功]: 移动后的文件或目录字符串.
[失败]: 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)
)
;| 重命名文件或目录
用法: (vldos-rename SourceFile/Directory[STRING] NewName[STRING])
参数1: 源文件或目录.
参数2: 新名称.
说明:
Move a file or a folder.
返回值:
[成功]: 重命名后的文件或目录.
[失败]: 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
)
;| 返回磁盘的类型
用法: (vldos-drivetype DriveLetter[STRING])
参数1: 盘符例如: "C:"
说明:
返回磁盘的类型
返回值:
[成功]: 磁盘的类型
[失败]: NIL
|;
(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
)
;| 返回当前的磁盘表
用法: (vldos-alldrive)
说明:
返回当前的磁盘表
返回值:
[成功]: 返回当前的磁盘表
[失败]: NIL
|;
(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
)
;| 返回磁盘的特定信息
用法: (vldos-driveinfo DriveLetter[STRING] key[STRING])
参数1: 盘符例如: "C:"
参数2: 所需磁盘信息的字符串
说明:
返回磁盘的特定信息
返回值:
[成功]: 磁盘的特定信息
[失败]: NIL
所需磁盘信息的字符串
"TOTALSIZE" 磁盘总空间
"FREESPACE" 磁盘可用空间
"DRIVETYPE" 磁盘类型
"FILESYSTEM" 文件系统类型
"SERIALNUMBER" 磁盘序列号
"SHARENAME" 共享名称
"VOLUMENAME" 磁盘卷标
|;
(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
)
;| 返回磁盘的所有信息
用法: (vldos-alldriveinfo DriveLetter[STRING])
参数1: 盘符例如: "C:"
说明:
返回磁盘的所有信息
返回值:
[成功]: 磁盘的所有信息
[失败]: NIL
|;
(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
)
;| 返回文件的特定信息
用法: (vldos-fileinfo Filename[STRING] key[STRING])
参数1: 文件全路径名
参数2: 所需文件信息的字符串
说明:
返回文件的特定信息
返回值:
[成功]: 文件的特定信息
[失败]: NIL
所需文件信息的字符串
"DATECREATED" 创建日期
"DATELASTMODIFIED" 修改日期
"DATELASTACCESSED" 最后一次访问时间
"TYPE" 文件类型
"SIZE" 文件大小
"ATTRIBUTES" 文件属性
|;
(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
)
;| 返回文件的所有信息
用法: (vldos-allfileinfo Filename[STRING])
参数1: 文件全路径名
说明:
返回文件的所有信息
返回值:
[成功]: 文件的所有信息
[失败]: NIL
|;
(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
)
;| 读文本文件到表 (快于 AutoLISP read-line函数)
用法: (vldos-readfile FilenameToRead[STRING])
参数1: 文本文件全路径名. (包括后缀名)
只有文本文件才能返回正确结果.
说明:
读文本文件到表
返回值:
[成功]: 返回包括文件内容的表
[失败]: 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
)
;| 将字符串或表写入文件 (快于 AutoLISP write-line函数)
用法: (vldos-writefile FileNameString[STRING] ContentStringList[LIST] ModeFlag[BOOLEAN])
(vldos-writefile FileNameString[STRING] ContentString[STRING] ModeFlag[BOOLEAN])
参数1: 文本文件全路径名. (包括后缀名)
参数2: 要写入文件的字符串或表
参数3: 最加或覆盖标志. nil 最加, T 覆盖
说明:
将字符串或表写入文件
返回值:
[成功]: 文本文件全路径名.
[失败]: 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
)
;| 目录浏览对话框
用法: (vldos-browsedir PromptString[STRING])
(vldos-writefile NIL)
参数1: 提示字符串, 如果是 nil, 缺省为 "Select Folder"
说明:
显示目录浏览对话框
返回值:
[成功]: 返回所选目录路径. 如果用户选择取消, 返回 NIL
[失败]: 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
)
;| 显示 windows 的确认对话框包括图标和可选按钮
用法: (vldos-msgbox TitleString[STRING] IconType[STRING/REAL] MessageString[STRING] ButtonType[INT])
参数1: 标题字符串, 如果是 nil, 缺省为 "Message"
参数2: 图标类型字符串或整数值. 如果是字符串, 只有第一个字符串有效.
参数3: 消息字符串, 如果是 nil, 缺省为 "Message HERE"
参数4: 按钮类型整数值.
说明:
显示 windows 的确认对话框
返回值:
[成功]: 所选按钮的值
[失败]: NIL
;;;按钮
;;;0 OK
;;;1 OK and Cancel
;;;2 Abort, Retry, and Ignore
;;;3 Yes, No, Cancel
;;;4 Yes and No
;;;5 Retry and Cancel
;;;图标类型
;;;16 [X] Stop Mark icon
;;;32 [?] Question Mark icon
;;;48 [!] Exclamation Mark icon
;;;64 [i] Information Mark icon
;;; 返回值所代表的按钮
;;;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
)
;| 当前目录文件搜索. 类似于 DIR /S 命令.
用法: (vldos-findfile FilenameFullPathString[STRING])
(vldos-writefile NIL)
参数1: 文件名. 可以包括扩展符 ("*" and "?").
如果文件名描述符为 nil ,返回所有的文件包括子目录。
说明:
当前目录文件搜索
返回值:
[成功]: 包括所有符合条件的文件名.
[失败]: 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
)
;| 合并两个文本文件
用法: (vldos-merge MergeBaseFilenameString[STRING] MergeFilenameString[STRING] EraseMergefileFlag[BOOLEAN])
参数1: 基文件名
参数2: 将被合并的文件名
参数3: 是否删除被合并文件的标志.
说明:
合并两个文件为一个e
返回值:
[成功]: 合并后的文件名
[失败]: 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
)
;| 通过IE 显示一个 HTML 字符串
用法: (vldos-text->ie ContentString[STRING])
参数1: 要显示的字符串或字符串表
说明:
传送数据至新打开的IE窗口
返回值:
[成功]: 包括字符串的新打开的IE窗口
[失败]: 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)
)
)
)
;| 显示时间/日期对话框
用法: (vldos-time)
说明:
通过VLisp调用时间/日期对话框
返回值:
[成功]: 显示时间/日期对话框
[失败]: NIL
|;
(Defun vldos-time (/ sys)
(if (setq sys (vlax-create-object "Shell.Application"))
(progn
(vlax-invoke-method sys 'settime)
(vlax-release-object sys)
)
)
)
[/FONT]

[FONT=courier new] 
;|  类型库智能化加载 
用法: (vlax-load-type-libeary ProgID[STRING] UniquePrefix[STR]) 
        (vlax-load-type-libeary ProgID[STRING] PrefixList[STR]) 
  参数1: 与vlax-get-create-object 函数相同的ProgID 字符串 
  参数2: 前缀，可以是字符串或表 
         表的顺序 (:methods-prefix :properties-prefix :constants-prefix) 
说明: 
    此函数读取 Windows REGISTRY 并且侦测合适的 DLL/OCX/EXE 类型库并自动加载 
 
返回值: 
[成功]: T 
[失败]: 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 
) 
 ;|  转换路径中字符 "/" 为 "\" 并返回大写值 
用法: (vldos-formatpath PathStringToFormat[STRING]) 
  参数1: 路径字符串 
说明: 
    此函数转换字符 "/" 为 "\". 
返回值: 
[成功]: 转换后的字符串 
[失败]: 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 
) 
 ;|  修改本地磁盘的卷标 
用法: (vldos-label DriveLetter[STRING] NewVolumnName[STRING]) 
  参数1: 盘符 例如: "C" 或 "C:" 
  参数2: 新卷标, 如果长度超过11个字符, 自动裁掉 
        <<< 本函数不检查字符串是否符合命名规则 >>> 
说明: 
    修改本地磁盘的卷标. 确保具有相应的权限进行此操作 
返回值: 
[成功]: 新卷标 
[失败]: 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 
) 
 ;|  执行 DOS DELTREE 命令 
用法: (vldos-deltree DirectoryToDelete[STRING]) 
  参数1: 要被删除的目录名称. 此函数不显示确认过程，删除文件夹和所有的子文件夹 
        如果参数是根目录，江删除所有的子目录. 
说明: 
    通过 ActiveX 执行 DOS DELTREE/Y 命令. 无需确认，无备份. 
    返回值: 
[成功]: T 
[失败]: 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 
) 
 ;|  创建目录 
用法: (vldos-mkdir DirectoryToCreate[STRING]) 
  参数1: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录. 
说明: 
    可创建多层目录. 
返回值: 
[成功]: 创建目录的全路径名 
[失败]: 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 
) 
 ;|  复制文件或目录 
用法: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING]) 
  参数1: 源文件或目录 
  参数2: 目标目录. 如果包含 "*\" or "*/", 此函数将在此路径下创建相同的子目录. 
说明: 
    复制文件或目录. 
返回值: 
[成功]: 复制的文件或目录字符串. 
[失败]: 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 
) 
|; 
 ;|  移动文件或目录 
用法: (vldos-move SourceFile/Directory[STRING] TargetFile/Directory[STRING]) 
  参数1: 源文件或目录. 
  参数2: 目标目录. 如果包含 "*\" or "*/", 此函数将在此路径下创建相同的子目录. 
说明: 
    移动文件或目录. 
返回值: 
[成功]: 移动后的文件或目录字符串. 
[失败]: 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) 
) 
 ;|  重命名文件或目录 
用法: (vldos-rename SourceFile/Directory[STRING] NewName[STRING]) 
  参数1: 源文件或目录. 
  参数2: 新名称. 
说明: 
    Move a file or a folder. 
返回值: 
[成功]: 重命名后的文件或目录. 
[失败]: 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 
) 
 ;|  返回磁盘的类型 
用法: (vldos-drivetype DriveLetter[STRING]) 
  参数1: 盘符 例如: "C:" 
说明: 
    返回磁盘的类型 
返回值: 
[成功]: 磁盘的类型 
[失败]: NIL 
|; 
(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 
) 
 
 ;|  返回当前的磁盘表 
用法: (vldos-alldrive) 
说明: 
    返回当前的磁盘表 
返回值: 
[成功]: 返回当前的磁盘表 
[失败]: NIL 
|; 
(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 
) 
 
 ;|  返回磁盘的特定信息 
用法: (vldos-driveinfo DriveLetter[STRING] key[STRING]) 
  参数1: 盘符 例如: "C:" 
  参数2: 所需磁盘信息的字符串 
说明: 
    返回磁盘的特定信息 
返回值: 
[成功]: 磁盘的特定信息 
[失败]: NIL 
所需磁盘信息的字符串 
"TOTALSIZE"    磁盘总空间 
"FREESPACE"    磁盘可用空间 
"DRIVETYPE"    磁盘类型 
"FILESYSTEM"   文件系统类型 
"SERIALNUMBER" 磁盘序列号 
"SHARENAME"    共享名称 
"VOLUMENAME"   磁盘卷标 
|; 
(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 
) 
 
 ;|  返回磁盘的所有信息 
用法: (vldos-alldriveinfo DriveLetter[STRING]) 
  参数1: 盘符 例如: "C:" 
说明: 
    返回磁盘的所有信息 
返回值: 
[成功]: 磁盘的所有信息 
[失败]: NIL 
|; 
(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 
) 
 
 ;|  返回文件的特定信息 
用法: (vldos-fileinfo Filename[STRING] key[STRING]) 
  参数1: 文件全路径名 
  参数2: 所需文件信息的字符串 
说明: 
    返回文件的特定信息 
返回值: 
[成功]: 文件的特定信息 
[失败]: NIL 
所需文件信息的字符串 
"DATECREATED"         创建日期 
"DATELASTMODIFIED"    修改日期 
"DATELASTACCESSED"    最后一次访问时间 
"TYPE"                文件类型 
"SIZE"                文件大小 
"ATTRIBUTES"          文件属性 
|; 
(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 
) 
 
 ;|  返回文件的所有信息 
用法: (vldos-allfileinfo Filename[STRING]) 
  参数1: 文件全路径名 
说明: 
    返回文件的所有信息 
返回值: 
[成功]: 文件的所有信息 
[失败]: NIL 
|; 
(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 
) 
 ;|  读文本文件到表 (快于 AutoLISP read-line函数) 
用法: (vldos-readfile FilenameToRead[STRING]) 
  参数1: 文本文件全路径名. (包括后缀名) 
        只有文本文件才能返回正确结果. 
说明: 
    读文本文件到表 
返回值: 
[成功]: 返回包括文件内容的表 
[失败]: 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 
) 
 ;|  将字符串或表写入文件 (快于 AutoLISP write-line函数) 
用法: (vldos-writefile FileNameString[STRING] ContentStringList[LIST] ModeFlag[BOOLEAN]) 
        (vldos-writefile FileNameString[STRING] ContentString[STRING] ModeFlag[BOOLEAN]) 
  参数1: 文本文件全路径名. (包括后缀名) 
  参数2: 要写入文件的字符串或表 
  参数3: 最加或覆盖标志. nil 最加, T 覆盖 
说明: 
    将字符串或表写入文件 
返回值: 
[成功]: 文本文件全路径名. 
[失败]: 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 
) 
 ;|  目录浏览对话框 
用法: (vldos-browsedir PromptString[STRING]) 
        (vldos-writefile NIL) 
  参数1: 提示字符串, 如果是 nil, 缺省为 "Select Folder" 
说明: 
    显示目录浏览对话框 
返回值: 
[成功]: 返回所选目录路径. 如果用户选择取消, 返回 NIL 
[失败]: 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 
) 
 ;|  显示 windows 的确认对话框包括图标和可选按钮 
用法: (vldos-msgbox TitleString[STRING] IconType[STRING/REAL] MessageString[STRING] ButtonType[INT]) 
  参数1: 标题字符串, 如果是 nil, 缺省为 "Message" 
  参数2: 图标类型字符串或整数值. 如果是字符串, 只有第一个字符串有效. 
  参数3: 消息字符串, 如果是 nil, 缺省为 "Message HERE" 
  参数4: 按钮类型整数值. 
说明: 
    显示 windows 的确认对话框 
返回值: 
[成功]: 所选按钮的值 
[失败]: NIL 
;;;按钮 
;;;0  OK 
;;;1  OK and Cancel 
;;;2  Abort, Retry, and Ignore 
;;;3  Yes, No, Cancel 
;;;4  Yes and No 
;;;5  Retry and Cancel 
;;;图标类型 
;;;16 [X] Stop Mark icon 
;;;32 [?] Question Mark icon 
;;;48 [!] Exclamation Mark icon 
;;;64 [i] Information Mark icon 
;;; 返回值所代表的按钮 
;;;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 
) 
 ;|  当前目录文件搜索. 类似于 DIR /S 命令. 
用法: (vldos-findfile FilenameFullPathString[STRING]) 
        (vldos-writefile NIL) 
  参数1: 文件名. 可以包括扩展符 ("*" and "?"). 
        如果文件名描述符为 nil ,返回所有的文件包括子目录。 
说明: 
    当前目录文件搜索 
返回值: 
[成功]: 包括所有符合条件的文件名. 
[失败]: 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 
) 
 ;| 合并两个文本文件 
用法: (vldos-merge MergeBaseFilenameString[STRING] MergeFilenameString[STRING] EraseMergefileFlag[BOOLEAN]) 
  参数1: 基文件名 
  参数2: 将被合并的文件名 
  参数3: 是否删除被合并文件的标志. 
说明: 
    合并两个文件为一个e 
返回值: 
[成功]: 合并后的文件名 
[失败]: 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 
) 
 ;| 通过IE 显示一个 HTML 字符串 
用法: (vldos-text->ie ContentString[STRING]) 
  参数1: 要显示的字符串或字符串表 
说明: 
    传送数据至新打开的IE窗口 
返回值: 
[成功]: 包括字符串的新打开的IE窗口 
[失败]: 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) 
    ) 
  ) 
) 
 ;| 显示时间/日期对话框 
用法: (vldos-time) 
说明: 
    通过VLisp调用时间/日期对话框 
返回值: 
[成功]: 显示时间/日期对话框 
[失败]: NIL 
|; 
(Defun vldos-time (/ sys) 
  (if (setq sys (vlax-create-object "Shell.Application")) 
    (progn 
      (vlax-invoke-method sys 'settime) 
      (vlax-release-object sys) 
    ) 
  ) 
) 
 
  [/FONT]

aidraft · 发表于 2004-7-4 11:04:50

不错，好东西。

xiaping · 发表于 2004-7-4 11:36:03

谢谢楼主，相当不错的资料。另外请问搂主有没有可按功能分类查询的Vlisp函数查询资料。

oyxx_1023 · 发表于 2005-1-21 19:54:47

P服啊。能把这么多外部应用程序研究透。不容易。

dbvbd · 发表于 2005-1-22 12:27:25

老大水平真高,我何时才能看懂呀

hmh888888 · 发表于 2005-1-23 09:47:08

怎么会这样？？？望高手指点迷津！！！
(vldos-driveinfo "d:" "SERIALNUMBER")
; 错误: 参数类型错误: numberp: #<variant 5 20964163584>

bigcat9898 · 发表于 2005-1-24 13:02:18

如此高深莫测，小弟不知何年才能看懂一点点。有没有基础一点的？

ldx110 · 发表于 2005-4-8 22:41:08

好高深东西，看来是达不到楼主的水平

aichong · 发表于 2005-4-8 22:49:37

哦，我一点基础都没有，实在是看不懂。
真佩服楼主的功底！

好的 · 发表于 2005-4-9 14:51:14

我也不懂，很高深啊

舟自横 · 发表于 2005-4-9 15:26:14

有些东西是要靠全面的知识才能摸的透的..
象这些东西你要是不懂"Scripting.FileSystemObject"
系统文件夹属性那你永远也搞不清他是什么意思
不过我可以教你们一个密技.....
用VLAX-DUMP-OBJECT去查各个对象的属性和应用方法
时间长了你就会慢慢了解其中的奥秘..

A活死人A · 发表于 2005-5-9 22:47:41

不懂，，不懂。。。还是不懂。。还是你们这高手高手高高手的话题吧了。。小弟。。。。服。。。

cdjtsf · 发表于 2005-5-10 08:21:41

lisp是文本解释型的能懂一点，vlisp看不明白，积累下来，慢慢学

KISSDY007 · 发表于 2005-5-10 23:48:02

我也不懂，很高深啊

LUCAS · 发表于 2005-5-11 08:14:05

最初由 hmh888888 发布
[B]怎么会这样？？？望高手指点迷津！！！
(vldos-driveinfo "d:" "SERIALNUMBER")
; 错误: 参数类型错误: numberp: #<variant 5 20964163584> [/B]

;;改了一下
;| 返回磁盤的所有信息
用法: (vldos-alldriveinfo DriveLetter[STRING])
參數1: 盤符例如: "C:"
說明:
返回磁盤的所有信息
返回值:
[成功]: 磁盤的所有信息
[失敗]: NIL
|;
(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 DRVOBJ "TotalSize") 1000.0)
(/ (vlax-get DRVOBJ "FreeSpace") 1000.0)
(vlax-get DRVOBJ "DriveType")
(vlax-get DRVOBJ "FileSystem")
(vlax-get DRVOBJ "SerialNumber")
(vlax-get DRVOBJ "ShareName")
(vlax-get DRVOBJ "VolumeName")
)
)
)
)
)
)
(if (equal (type DRVOBJ) 'VLA-OBJECT)
(vlax-release-object DRVOBJ)
)
(vlax-release-object FILSYS)
)
)
RETVAL
)

;;改了一下 
 ;|  返回磁盤的所有信息 
用法: (vldos-alldriveinfo DriveLetter[STRING]) 
  參數1: 盤符 例如: "C:" 
說明: 
    返回磁盤的所有信息 
返回值: 
[成功]: 磁盤的所有信息 
[失敗]: NIL 
|; 
(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 DRVOBJ "TotalSize") 1000.0) 
                     (/ (vlax-get DRVOBJ "FreeSpace") 1000.0) 
                     (vlax-get DRVOBJ "DriveType") 
                     (vlax-get DRVOBJ "FileSystem") 
                     (vlax-get DRVOBJ "SerialNumber") 
                     (vlax-get DRVOBJ "ShareName") 
                     (vlax-get DRVOBJ "VolumeName") 
                   ) 
                  ) 
                ) 
               ) 
             ) 
      ) 
      (if (equal (type DRVOBJ) 'VLA-OBJECT) 
        (vlax-release-object DRVOBJ) 
      ) 
      (vlax-release-object FILSYS) 
    ) 
  ) 
  RETVAL 
)

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

[推荐]：我翻译整理的VLISP磁盘操作函数

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

相关帖子