Directory select with only lisp

I finally got this to work (hopefully it works for other also). I am posting the code and attaching the ".dcl" file for anyone to use. The main routine is "directory-dia".
Have fun.
Tim

ps. erase the ".zip" to use the dcl file.

(defun list-drives ( / c i)
;By Tony Tanzillo

(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 directory-dia(/ dplc dsub listvl rslt ddia1)

(setq ddia1 (load_dialog "DirSelect.dcl"))
(if (not (new_dialog "Direct" ddia1))
(exit)
);-if
(list-drives)
(mode_tile "d-save" 1)
(mode_tile "lbox1" 2)
(start_list "lbox1" 3); clear the list
(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 1)
)"
)
(start_dialog)

)

;============================================

(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 "choice1" dpathdir)
)
(progn
(start_list "lbox1" 3)
(mapcar 'add_list rslt)
(end_list)
(setq dpathdir nil)
(setq dsub nil)
(set_tile "choice1" "")
)
)
)

;===============================================

(defun step1back(/ cnt1)

(setq cnt1 (strlen dpathdir))
(setq cnt1 (1- cnt1))
(while (and (/= (substr dpathdir cnt1 1) "\\") (> cnt1 1))
(setq dpathdir (substr dpathdir 1 (1- cnt1)))
(setq cnt1 (1- cnt1))
)
(if (<= cnt1 1)
(setq flag1 "no")
)

)

 

Nice...........

Gary

the code and attaching the ".dcl" file for anyone to use. The main routine is
"directory-dia".

 

Added this to dcl file for bold text in the list box
fixed_width_font=true;

Gary



Direct:dialog {label="Select Directory";
:row {
:list_box {key="lbox1"; width=60; height=15; multiple_select=true;
fixed_width_font=true;}
}
:text {key="choice1";}
:row {
:spacer {}
:button {label="OK"; is_default=true; allow_accept=true; key="accept";
width=8; fixed_width=true;}
:button {label="Cancel"; is_cancel=true; key="cancel"; width=8;
fixed_width=true;}
:spacer {}
}
}

 

Gary,

Nice idea (I added it now also). Still learning dcl, so thanks for the tip.

Tim

 

And added it here
:text {key="choice1"; fixed_width_font=true;}

Gary

 

Should take out this I guess:
multiple_select=true;
from the list box. It doesn't really matter because I don't use the variable used from it, but just in case.

Tim

 

That's right, or use
multiple_select=false;

Question: how do you use this routine and the global varable dpathdir?

Gary

used from it, but just in case.

 

Here is a revised one. I added a (vl-propagate... so that it will start again in the last directory it found, in any drawing it is used in in the current acad session. I like the way it works better now.

Tim


(defun list-drives ( / c i)
;By Tony Tanzillo
;Revised by Tim Willey

(if dpathdir
(progn
(setq rslt (vl-directory-files dpathdir nil -1))
(if (= rslt nil)
(setq rslt (list ".."))
(if (not (member ".." rslt))
(setq rslt (reverse (append (reverse rslt) (list ".."))))
)
)
(setq rslt (vl-remove "." rslt))
(start_list "lbox1" 3)
(mapcar 'add_list rslt)
(end_list)
(set_tile "choice1" dpathdir)
)
(progn
(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 directory-dia(/ dplc dsub listvl rslt ddia1)

(setq ddia1 (load_dialog "DirSelect.dcl"))
(if (not (new_dialog "Direct" ddia1))
(exit)
);-if
(list-drives)
(mode_tile "d-save" 1)
(mode_tile "lbox1" 2)
(start_list "lbox1" 3); clear the list
(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 1)
)"
)
(vl-propagate 'dpathdir)
(start_dialog)

)

;============================================

(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 "choice1" dpathdir)
)
(progn
(start_list "lbox1" 3)
(mapcar 'add_list rslt)
(end_list)
(setq dpathdir nil)
(setq dsub nil)
(set_tile "choice1" "")
)
)
)

;===============================================

(defun step1back(/ cnt1)

(setq cnt1 (strlen dpathdir))
(setq cnt1 (1- cnt1))
(while (and (/= (substr dpathdir cnt1 1) "\\") (> cnt1 1))
(setq dpathdir (substr dpathdir 1 (1- cnt1)))
(setq cnt1 (1- cnt1))
)
(if (<= cnt1 1)
(setq flag1 "no")
)

)

 

Ditch the DCL.

Try this:

(defun BrowseForFolder ( / sh folder parentfolder folderobject result)
(vl-load-com)
(setq sh
(vla-getInterfaceObject
(vlax-get-acad-object)
"Shell.Application"
)
)

(setq folder
(vlax-invoke-method
sh
'BrowseForFolder
0
""
0
)
)
(vlax-release-object sh)

(if folder
(progn
(setq parentfolder
(vlax-get-property folder 'ParentFolder)
)
(setq FolderObject
(vlax-invoke-method
ParentFolder
'ParseName
(vlax-get-property Folder 'Title)
)
)
(setq result
(vlax-get-property FolderObject 'Path)
)
(mapcar 'vlax-release-object
(list folder parentfolder folderobject)
)
result
)
)
)

".dcl" file for anyone to use. The main routine is "directory-dia".

 

Tony,

Thanks. That is exactly what I wanted but I didn't know how to get there. I will have to study your code to understand it.

Tim

 

If you're using (vlax-dump-object) you won't see them.

You have to look in MSDN to find out what methods/properties are supported.

 

Hmmmm... I didn't notice the 'Self' property before, which
makes it a bit simpler:

(defun BrowseForFolder ( / sh folder folderobject result)
(vl-load-com)
(setq sh
(vla-getInterfaceObject
(vlax-get-acad-object)
"Shell.Application"
)
)

(setq folder
(vlax-invoke-method
sh
'BrowseForFolder
0
""
0
)
)
(vlax-release-object sh)

(if folder
(progn
(setq folderobject
(vlax-get-property folder 'Self)
)
(setq result
(vlax-get-property FolderObject 'Path)
)
(vlax-release-object folder)
(vlax-release-object FolderObject)
result
)
)
)

 

Ok Tony, I give up . . . where do you find the methods associated with an
IShellDispatch2 object?

jb

posting the code and attaching the

 

Yep - got it! Was hoping for a FileNav dialog . . .

http://msdn.microsoft.com/library/d...l/reference/objects/shell/browseforfolder.asp

 

Thanks for this,

I have found that I can can have a string prompt (see below),
is it possible to have a starting path also (like DOS_Getdir)?

; Example: (ALE_BrowseForFolder "Select drawings folder")
;
; Original BrowseForFolder by Tony Tanzillo
;
(defun ALE_BrowseForFolder (PrmStr / ShlObj Folder FldObj OutVal)
(vl-load-com)
(setq
ShlObj (vla-getInterfaceObject (vlax-get-acad-object)
"Shell.Application")
Folder (vlax-invoke-method ShlObj 'BrowseForFolder 0 PrmStr 0)
)
(vlax-release-object ShlObj)
(if Folder
(progn
(setq
FldObj (vlax-get-property Folder 'Self)
OutVal (vlax-get-property FldObj 'Path)
)
(vlax-release-object Folder)
(vlax-release-object FldObj)
OutVal
)
)
)

 

This is interesting too...

(defun crac2 (/ shlobj)
(vl-load-com)
(setq
ShlObj (vla-getInterfaceObject
(vlax-get-acad-object)
"Shell.Application"
)
)
(vlax-invoke-method ShlObj 'Explore (getvar "dwgprefix"))
(vlax-release-object ShlObj)
)

 

I'd also like to know if there is a way to default to a thumbnail view.

Don