[LISP函数]：选择目录函数

mmmm · 发表于 2004-8-4 10:34:41

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

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

×

(defun Sel-dir (/ action-list2file list-drives
update-dia step1back DATA DCL
DDIA1 DPATHDIR DPLC DSUB
FLAG1 LISTVL RSLT
)
(defun action-list2file (data filex / ff xx)
(if (setq ff (open filex "w"))
(progn
(foreach xx data (write-line xx ff))
(setq ff (close ff))
(while (null (findfile filex)))
)
)
(findfile filex)
)
(defun list-drives (/ c i)
(setq i 66)
(repeat 24
(setq c (chr (setq i (1+ i))))
(if (findfile (strcat c ":\\."))
(setq rslt (cons (strcat c ":") rslt))
)
)
(setq rslt (reverse rslt))
)
(defun update-dia (/ flag1)
(setq dplc (atoi $value))
(if (not dsub)
(setq listvl (strcat (nth dplc rslt) "\"))
(setq listvl (strcat (nth dplc dsub) "\"))
)
(if (= listvl "..\")
(step1back)
(if dpathdir
(setq dpathdir (strcat dpathdir listvl))
(setq dpathdir listvl)
)
)
(if (/= flag1 "no")
(progn
(setq dsub (vl-directory-files dpathdir nil -1))
(if (= dsub nil)
(setq dsub (list ".."))
(if (not (member ".." dsub))
(setq dsub (reverse (append (reverse dsub) (list ".."))))
)
)
(setq dsub (vl-remove "." dsub))
(start_list "lbox1" 3)
(mapcar 'add_list dsub)
(end_list)
(set_tile "error" dpathdir)
)
(progn
(start_list "lbox1" 3)
(mapcar 'add_list rslt)
(end_list)
(setq dpathdir nil)
(setq dsub nil)
(set_tile "error" "")
)
)
)
(defun step1back (/ cnt1)
(setq cnt1 (1- (strlen dpathdir)))
(while (and (/= (substr dpathdir cnt1 1) "\") (> cnt1 1))
(setq dpathdir (substr dpathdir 1 (1- cnt1))
cnt1 (1- cnt1)
)
)
(if (<= cnt1 1)
(setq flag1 "no")
)
)
(setq data (list
"dcl_settings : default_dcl_settings { audit_level=0;}"
"SelDir:dialog {label=\042Select Directory\042;" ":row {"
":list_box {key=\042lbox1\042; width=45; height=15; multiple_select=true;fixed_width_font=true;}}"
"errtile;ok_cancel;}")
dcl (strcat (vl-filename-directory (findfile "acad.exe"))
"\\sel-dir.DCL"
)
)
(if (and (setq dcl (action-list2file data dcl))
(setq ddia1 (load_dialog dcl))
(new_dialog "SelDir" ddia1)
)
(progn
(list-drives)
(mode_tile "d-save" 1)
(mode_tile "lbox1" 2)
(start_list "lbox1" 3)
(mapcar 'add_list rslt)
(end_list)
(action_tile "lbox1" "(if (= $reason 4) (UPDATE-DIA))")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(progn(setq dpathdir nil)(done_dialog 0))")
(start_dialog)
(unload_dialog ddia1)
(vl-file-delete dcl)
)
)
dpathdir
)

(defun Sel-dir (/            action-list2file            list-drives 
                update-dia  step1back        DATA            DCL 
                DDIA1            DPATHDIR        DPLC            DSUB 
                FLAG1            LISTVL        RSLT 
               ) 
  (defun action-list2file (data filex / ff xx) 
    (if        (setq ff (open filex "w")) 
      (progn 
        (foreach xx data (write-line xx ff)) 
        (setq ff (close ff)) 
        (while (null (findfile filex))) 
      ) 
    ) 
    (findfile filex) 
  ) 
  (defun list-drives (/ c i) 
    (setq i 66) 
    (repeat 24 
      (setq c (chr (setq i (1+ i)))) 
      (if (findfile (strcat c ":\\.")) 
        (setq rslt (cons (strcat c ":") rslt)) 
      ) 
    ) 
    (setq rslt (reverse rslt)) 
  ) 
  (defun update-dia (/ flag1) 
    (setq dplc (atoi $value)) 
    (if        (not dsub) 
      (setq listvl (strcat (nth dplc rslt) "\")) 
      (setq listvl (strcat (nth dplc dsub) "\")) 
    ) 
    (if        (= listvl "..\") 
      (step1back) 
      (if dpathdir 
        (setq dpathdir (strcat dpathdir listvl)) 
        (setq dpathdir listvl) 
      ) 
    ) 
    (if        (/= flag1 "no") 
      (progn 
        (setq dsub (vl-directory-files dpathdir nil -1)) 
        (if (= dsub nil) 
          (setq dsub (list "..")) 
          (if (not (member ".." dsub)) 
            (setq dsub (reverse (append (reverse dsub) (list "..")))) 
          ) 
        ) 
        (setq dsub (vl-remove "." dsub)) 
        (start_list "lbox1" 3) 
        (mapcar 'add_list dsub) 
        (end_list) 
        (set_tile "error" dpathdir) 
      ) 
      (progn 
        (start_list "lbox1" 3) 
        (mapcar 'add_list rslt) 
        (end_list) 
        (setq dpathdir nil) 
        (setq dsub nil) 
        (set_tile "error" "") 
      ) 
    ) 
  ) 
  (defun step1back (/ cnt1) 
    (setq cnt1 (1- (strlen dpathdir))) 
    (while (and (/= (substr dpathdir cnt1 1) "\") (> cnt1 1)) 
      (setq dpathdir (substr dpathdir 1 (1- cnt1)) 
            cnt1     (1- cnt1) 
      ) 
    ) 
    (if        (<= cnt1 1) 
      (setq flag1 "no") 
    ) 
  ) 
 
  (setq        data (list 
               "dcl_settings : default_dcl_settings { audit_level=0;}" 
               "SelDir:dialog {label=\042Select Directory\042;"        ":row {" 
               ":list_box {key=\042lbox1\042; width=45; height=15; multiple_select=true;fixed_width_font=true;}}" 
               "errtile;ok_cancel;}") 
        dcl  (strcat (vl-filename-directory (findfile "acad.exe")) 
                     "\\sel-dir.DCL" 
             ) 
  ) 
  (if (and (setq dcl (action-list2file data dcl)) 
           (setq ddia1 (load_dialog dcl)) 
           (new_dialog "SelDir" ddia1) 
      ) 
    (progn 
      (list-drives) 
      (mode_tile "d-save" 1) 
      (mode_tile "lbox1" 2) 
      (start_list "lbox1" 3) 
      (mapcar 'add_list rslt) 
      (end_list) 
      (action_tile "lbox1" "(if (= $reason 4) (UPDATE-DIA))") 
      (action_tile "accept" "(done_dialog 1)") 
      (action_tile "cancel" "(progn(setq dpathdir nil)(done_dialog 0))") 
      (start_dialog) 
      (unload_dialog ddia1) 
      (vl-file-delete dcl) 
    ) 
  ) 
  dpathdir 
)

梦断江南 · 发表于 2004-8-4 13:25:08

(sel-dir) 返回 nil？应该至少有个返回值吧？

mmmm · 发表于 2004-8-4 14:12:11

你没有在盘符或列表中选择，当然是NIL了

hqd9639 · 发表于 2004-8-4 16:59:50

c:盘呢？

lsjjm · 发表于 2004-8-5 05:04:37

是呀,C,D..盘都没有了. 能详细说说程序的功能吗?

LUCAS · 发表于 2004-8-5 08:34:24

收藏----选择檔案函数(作者:忘了記錄..)

LUCAS · 发表于 2004-8-5 08:38:00

附圖:
可是程序沒有選擇磁碟機功能!
當然你可以自己加上去!

LUCAS · 发表于 2004-8-5 08:45:39

加了選擇磁碟機功能!如附圖:無提供: 8-(

jyzas · 发表于 2013-8-12 06:59:24

下来试下先:)

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

[LISP函数]：选择目录函数

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

相关帖子