REBOL [ file: %request-dir.r title: "Directory selector (treeview)" name: author: "Didier CADIEU" email: %didec--wanadoo--fr date: 11-09-2003 version: 1.0.0 needs: {Work only on View 1.2.8+} purpose: { Open a requestor to select a directory. The current directories path is shown as a tree, and sub-dirs are shown for selection. } comment: { The make-dir button does not work as you can expect due to a bug in the management of modale window in view : the directory is created only when the function return. You can use the patch from Romano Paolo Tenca to correct this behaviour. This script is based on a work from Carl Sassenrath, found in the Mailing list } library: [ level: 'advanced platform: 'all type: [module function] domain: [file-handling files ui vid] tested-under: "View 1.2.8 Win2K" license: 'public-domain support: "use email" ] ] ctx-req-dir: context [ max-dirs: cnt: 0 f-list: f-txt: f-slid: f-path: path: last-path: result: dirs: none list-data: copy [] links: [ [draw [pen 0.0.0 line 6x0 6x9 12x9]] [draw [pen 0.0.0 line 6x0 6x18 line 6x9 12x9]] ] lib: pth: lev: none dec: 11 dirout: [ origin 8x8 space 0x0 vh3 "Select a directory" across pad 0x4 f-list: list 300x292 180.180.180 [ origin 0 space 0 across box 16x18 f-txt: text 300 font-size 11 font [colors: [0.0.0 0.0.0]] [chg-dir face/user-data] ] supply [ count: count + cnt if count > length? list-data [face/show?: false exit] face/show?: true set [lib pth lev] pick list-data count either index = 1 [ face/offset/x: lev - dec face/effect: pick links not attempt [(third pick list-data count + 1) = lev] ] [ face/text: lib face/color: pick [240.240.240 220.220.220] odd? count face/offset/x: lev if path = face/user-data: pth [face/color: 255.190.80 250.150.150] ] ] f-slid: scroller 16x292 [ c: to-integer value * ((length? list-data) - max-dirs) if c <> cnt [cnt: c show f-list] ] return space 60x4 f-path: field wrap font-size 11 316x40 [ value: attempt [to-rebol-file to-file f-path/text] if all [value exists? value] [path: value show-dir] ] return btn-enter 65 "Open" [result: dirize path hide-popup] btn 65 "Make Dir" [ value: request-text/title "Directory name:" if value [ trim value if not empty? value [ either error? try [make-dir rejoin [dirize path value]] [ alert "Cannot create directory." path: copy last-path ] [chg-dir path] ] ] ] btn-cancel 65 "Cancel" [hide-popup] ] chg-dir: func [file][ if none? file [exit] last-path: copy path path: copy file show-dir ] ; build a tree of dirs from first to last in the path, recursively build-tree: func [p /local b l] [ b: split-path p l: 0 if not none? second b [l: dec + build-tree first b] either b/2 [any [slash <> last b/2 remove back tail b/2]][change at b 2 "(root)"] append/only list-data reduce [any [second b "(root)"] p l] l ] show-dir: has [l d] [ ; read contents of path dirs: attempt [load dirize path] if not dirs [ path: last-path if not dirs: attempt [load dirize path][ alert reform ["Invalid directory:" path] dirs: load path: %/ ] ] ; keep only sub-dirs remove-each file dirs [slash <> last file] clear list-data ; recontruct the tree for the path l: dec + build-tree path ; append the sub-dirs foreach file sort dirs [ replace/all file #"/" "" append/only list-data reduce [file rejoin [dirize path file] l] ] ; show everything f-path/text: any [attempt [to-local-file path] copy ""] f-slid/redrag max-dirs / max 1 length? list-data f-slid/step: either 0 >= d: (length? list-data) - max-dirs [0][1 / d] f-slid/data: 0.0 cnt: 0 show [f-list f-slid f-path] ] set 'request-dir func [ "Requests a directory using pseudo treeview." /keep "Keep previous directory path" /dir "Set starting directory" where [file!] /offset xy /local ][ if block? dirout [ dirout: layout dirout max-dirs: to-integer f-list/size/y - 4 / f-txt/size/y center-face dirout ] if not all [keep path] [path: any [where what-dir]] if all [not empty? path slash = last path][remove back tail path] last-path: path result: none show-dir either offset [inform/offset dirout xy][inform dirout] result ] ] ;request-dir