[LISP程序]："搜查令"完整版

舟自横

前面写了一个子程序但是无法演示
索性写了一个带对话框的完整版..
[PHP]
(defun c:hysearch(/ SS DCL_ID DD FILENAME FOLDER)
  (setq dcl_id (load_dialog "hysearch"))
  (new_dialog "hysearch" dcl_id)
  (action_tile "zd" "(set_tile \"lj\" (hy_getFolder \"請指定路徑:\"))")
  (action_tile "accept" "(ok_hysearch)(if (devhysearch) (done_dialog 1)
  (memsgbox2 \"文件名不能空或不支持該種文件!\" 16 \"錯誤信息\" 0))")
  (setq dd (start_dialog))
  (if (= dd 1)
    (if (setq ss (hy_searchfolderss folder filename))
      (hysearch1 ss)
    )
  )
  )
(defun ok_hysearch()
  (setq filename (get_tile "np"))
  (setq folder (get_tile "lj"))
  )
(defun devhysearch()
  (and filename
       (/= (vl-string-trim " " filename) "")
       (vl-filename-extension filename)
       (member (strcase(vl-filename-extension filename))
               '(".LSP" ".TXT" ".NC" ".CNC" ".DAT" ".INI")
               )
  )
  )
(defun hysearch1(ss1 /  DCL_ID DX tIL)
  (setq til nil)
  (setq dcl_id (load_dialog "hysearch1"))
  (new_dialog "hysearch1" dcl_id)
  (start_list "op")
  (mapcar 'add_list ss1)
  (end_list)
  (action_tile "op" "(setq til (nth (atoi $value) ss1))")
  (action_tile "del" "(if (= 1 (mess til)) (progn (vl-file-delete til)
  (insdo (get_tile \"op\"))))")
  (action_tile "accept" "(if til (done_dialog 1)
    (memsgbox2 \"請選擇需要打開的文件!\" 32 \"錯誤信息\" 0))")
  (setq dx (start_dialog))
  (if (= dx 1)
    (startapp "notepad" til))
  )

(defun mess(ti)
  (memsgbox2 (strcat "確定要刪除文件" ti "?")
                             33 "提示信息" 0)
  )
(defun insdo(index)
   (start_list "op" 1 (atoi index)) (add_list " ") (end_list)
  )

(defun hy_searchfolderss  (fols file / fol subfolders1 pathlist)
  (setq pathlist nil)
(defun hy_searchfolderss1(fols file)
  (setq olderror *error*)
  (defun *error*(msg)(setq *error* olderror)(grtext)(princ)(princ))
  (setq SYS (vlax-get-or-create-object "Scripting.FileSystemObject"))
  (setq fol (vlax-invoke sys 'getfolder fols))
   (setq fils (vlax-get-property fol 'files))
   (vlax-for item fils
    (progn (grtext -1 "正在搜索:")(grtext -2 (setq nep (vlax-get-property item 'path)))
              (vla-eval (vlax-get-acad-object) "DoEvents")
                   (if (= (strcase file)(strcase(vlax-get-property item 'name)))
                           (setq pathlist (cons nep pathlist)
                            ))
    )
    )
   (if (setq subfolders1 (vlax-get-property fol 'SubFolders))
      (vlax-for item subfolders1 (hy_searchfolderss1 item file))
    )
    )
  (hy_searchfolderss1 fols file)
  (grtext)
   pathlist
  )
(defun memsgbox2(msg flg tit time / ws)
  (setq *wsh (vlax-create-object "wscript.shell"))
  (setq ws (vlax-invoke *wsh 'popup msg time tit flg))
  (vlax-release-object *wsh)
  ws
  )
(defun hy_getFolder (msg / WinShell shFolder path catchit);;;
  (vl-load-com)
  (setq winshell (vlax-create-object "Shell.Application"))
  (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
  (setq
    catchit (vl-catch-all-apply
              '(lambda ()
                 (setq shFolder (vlax-get-property shFolder 'self))
                 (setq path (vlax-get-property shFolder 'path))
               )
            )
  )
  (if (vl-catch-all-error-p catchit)
    nil
    path
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;以下为对话框程序;;;;;;;;;;;;;;;;;;;;;;;
hysearch1:dialog{
        label="★★★超級搜查令★★★";
        :row{
        :image{fixed_height=true;height=0.1;width=45;color=24;}
        :text_part {label="***搜***搜***搜***";}
        }
        :list_box{label="搜索到文件:";key="op";height=20;}
        : row {
       : button {label="打    開";width=7;key="accept";}
       : button {label="刪    除";width=7;key="del";}
       : button {label="退    出";is_cancel=true;width=7;key="cancel";}
           }
        }
hysearch:dialog{
        label="★★★超級搜查令★★★";
        :row{
        :image{fixed_height=true;height=0.1;width=45;color=24;}
        :text_part {label="***搜***搜***搜***";}
        }
        :edit_box{label="輸入文件名(包含擴展名):";key="np";}
        :row{
        :edit_box{label="輸入搜索路徑:";key="lj";value="c:\\\\";width=30;}
        :button {label="指定路徑";key="zd";}
        }
        : row {
       : button {label="開始搜查";width=10;key="accept";}
       : button {label="退    出";is_cancel=true;width=10;key="cancel";}
           }
        }
[/PHP]
将hysearch1:dialog程序存为hysearch1.DCL
将hysearch:dialog程序存为hysearch.DCL
将主程序加载
测试
(DEFUN C:TT()
(c:hysearch)
)
看一下效果..不比WINDOWS带的搜索功能差吧....
文件只支持NOTEPAD打开的文件
附件里有动态演示..我的SWF怎么也穿不上不知道为何
请斑竹帮忙做一个用附件里面的就好

snoopychen

周兄啊，hy_getFolder好像没有定义
程序暂时运行没有结果

舟自横

呵呵..不好意思..加上..
(defun hy_getFolder (msg / WinShell shFolder path catchit);;;
  (vl-load-com)
  (setq winshell (vlax-create-object "Shell.Application"))
  (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
  (setq
    catchit (vl-catch-all-apply
              '(lambda ()
                 (setq shFolder (vlax-get-property shFolder 'self))
                 (setq path (vlax-get-property shFolder 'path))
               )
            )
  )
  (if (vl-catch-all-error-p catchit)
    nil
    path
  )
)