;|  类型库智能化加载
用法: (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-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
)

 ;|  读文本文件到表 (快于 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)
    )
  )
)