1 2######################################################### 3# Directory Selector TCL version 1.1 4# 5# Originally written by: 6# Daniel Roche, <dan@lectra.com> 7# 8# Modified for xmktclapp (and for version of Tk prior to 8.0) by: 9# D. Richard Hipp, <drh@hwaci.com> 10 11# tk_getDirectory [option value ...] 12# 13# options are : 14# [-parent window] parent window 15# [-initialdir dir] display in dir 16# [-title string] make string title of dialog window 17# [-ok string] make string the label of OK button 18# [-cancel string] make string the label of CANCEL button 19# [-label string] make string the label of the directory message 20# [-nofiles] don't show files 21# 22 23proc tk_getDirectory {args} { 24 global tcl_platform tk_getDirectory 25 26 set _titre "Directory Selector" 27 set _ldir Directory: 28 set _open Ok 29 set _cancel Cancel 30 set _parent {} 31 set tk_getDirectory(curdir) [pwd] 32 set tk_getDirectory(showfiles) 1 33 34 set ind 0 35 set max [llength $args] 36 while { $ind < $max } { 37 switch -exact -- [lindex $args $ind] { 38 "-parent" { 39 incr ind 40 set _parent [lindex $args $ind] 41 incr ind 42 } 43 "-initialdir" { 44 incr ind 45 if {![catch {cd [lindex $args $ind]}]} { 46 set dir [pwd] 47 catch {cd $tk_getDirectory(curdir)} 48 set tk_getDirectory(curdir) $dir 49 } 50 incr ind 51 } 52 "-title" { 53 incr ind 54 set _titre [lindex $args $ind] 55 incr ind 56 } 57 "-ok" { 58 incr ind 59 set _open [lindex $args $ind] 60 incr ind 61 } 62 "-cancel" { 63 incr ind 64 set _cancel [lindex $args $ind] 65 incr ind 66 } 67 "-label" { 68 incr ind 69 set _ldir [lindex $args $ind] 70 incr ind 71 } 72 "-nofiles" { 73 set tk_getDirectory(showfiles) 0 74 incr ind 75 } 76 default { 77 puts "unknown option [lindex $args $ind]" 78 return "" 79 } 80 } 81 } 82 83 set tk_getDirectory(fini) 0 84 85 if {![info exists tk_getDirectory:b_up]} { 86 image create photo tk_getDirectory:b_up -data {\ 87R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\ 88/wD//////yH5BAEAAAgALAAAAAAQABAAQwQ4EMlJKwJvZaB7fsD1eSQolmV4kaqFaUA8fuG7\ 89xTht7S7e9r4gTsKhzTo1mO+YNKKaqFFNSP3xKhEAOw==} 90 91 image create photo tk_getDirectory:b_new -data {\ 92R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\ 93/wD//////yH5BAEAAAgALAAAAAAQABAAQwQ1EMlJKwJv5a0BsNVHiZhmbiKohid5jVzsXl5t\ 94p+uE569lS5+g7vZ7BU9IIRDJ2QGYph2vEgEAOw==} 95 96 image create photo tk_getDirectory:b_dir -data {\ 97R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\ 98/wD//////yH5BAEAAA4ALAAAAAAQABAAQwQ+0MlJqzsPLc33PsD1jGQ5gtehruwaXh1yWBIW\ 99exxq47z80sAaK3i4yVq1R4+nUxo9zWUn+tSgHICsdrsNAiMAOw==} 100 101 image create photo tk_getDirectory:b_file -data {\ 102R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\ 103/wD//////yH5BAEAAAgALAAAAAAQABAAQwQ3EMlJ6wTvkb0zqJjWfR+Ycd1TXkDrrqZIZF6M\ 104zir47rDlUyGaqicJ0l4x4TGpzAGbyyfU+atGAAA7} 105 106 image create bitmap tk_getDirectory:b_down -data " 107#define down_width 13 108#define down_height 10 109static unsigned char down_bits[] = { 110 0x00, 0x00, 0x00, 0x00, 0xfe, 0x0f, 0xfc, 0x07, 0xf8, 0x03, 0xf0, 0x01, 111 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00};" 112 } 113 114 set w .dirsel 115 catch {destroy $w} 116 117 toplevel $w 118 wm geometry $w 420x220 119 wm title $w $_titre 120 if {$_parent == "" || ![winfo exists $_parent]} { 121 set _parent [winfo toplevel [winfo parent $w]] 122 } else { 123 set _parent [winfo toplevel $_parent] 124 } 125 wm transient $w $_parent 126 127 frame $w.f1 -relief flat -borderwidth 0 128 frame $w.f2 -relief sunken -borderwidth 1 129 frame $w.f3 -relief flat -borderwidth 0 130 pack $w.f1 -fill x -padx 6 -pady 5 131 pack $w.f2 -fill both -expand 1 -padx 6 132 pack $w.f3 -fill x -padx 6 -pady 3 133 134 label $w.f1.lab -text "Look In:" 135 frame $w.f1.dir -relief sunken -bd 2 136 entry $w.f1.dir.ent -relief flat -textvariable tk_getDirectory(curdir) \ 137 -state disabled -cursor {} 138 menubutton $w.f1.dir.but -relief raised -image tk_getDirectory:b_down \ 139 -menu $w.f1.dir.but.m -direction left 140 menu $w.f1.dir.but.m -tearoff 0 141 pack $w.f1.dir.ent -side left -fill x -expand 1 142 pack $w.f1.dir.but -side right -fill y 143 button $w.f1.up -image tk_getDirectory:b_up \ 144 -command "tk_getDirectory:UpDir $w" 145 button $w.f1.new -image tk_getDirectory:b_new \ 146 -command "tk_getDirectory:NewDir $w" 147 pack $w.f1.lab -side left 148 pack $w.f1.dir -side left -fill x -expand 1 149 pack $w.f1.new -side right 150 pack $w.f1.up -side right -padx 8 151 152 bind $w.f1.dir.but <1> "tk_getDirectory:Menu $w" 153 bind $w.f1.dir.ent <1> "tk_getDirectory:Menu $w;$w.f1.dir.but.m post %X %Y" 154 155 canvas $w.f2.cv -borderwidth 0 -xscrollcommand "$w.f2.sb set" \ 156 -height 10 -bg white 157 scrollbar $w.f2.sb -command "$w.f2.cv xview" -orient horizontal 158 pack $w.f2.cv -side top -fill both -expand 1 159 pack $w.f2.sb -side top -fill x 160 161 $w.f2.cv bind TXT <Any-Button> "tk_getDirectory:HighlightItem $w" 162 $w.f2.cv bind IMG <Any-Button> "tk_getDirectory:HighlightItem $w" 163 $w.f2.cv bind TXT <Any-Double-Button> "tk_getDirectory:ClickItem $w" 164 $w.f2.cv bind IMG <Any-Double-Button> "tk_getDirectory:ClickItem $w" 165 166 label $w.f3.lab -text $_ldir 167 entry $w.f3.ent -relief sunken -textvariable tk_getDirectory(seldir) \ 168 -state disabled -cursor {} 169 pack $w.f3.lab -side left 170 pack $w.f3.ent -side left -fill x -expand 1 171 172 set width [string length $_open] 173 if {$width < [string length $_cancel]} { 174 set width [string length $_cancel] 175 } 176 if {$tcl_platform(platform) == "windows"} { 177 button $w.f3.open -width $width -text $_open -pady 0 \ 178 -default active -command {set tk_getDirectory(fini) 1} 179 button $w.f3.cancel -width $width -text $_cancel -pady 0 \ 180 -command {set tk_getDirectory(fini) 0} 181 } else { 182 button $w.f3.open -width $width -text $_open \ 183 -default active -command {set tk_getDirectory(fini) 1} 184 button $w.f3.cancel -width $width -text $_cancel \ 185 -command {set tk_getDirectory(fini) 0} 186 } 187 pack $w.f3.cancel -side right 188 pack $w.f3.open -side right -padx 8 189 190 bind $w <Return> "$w.f3.open flash; set tk_getDirectory(fini) 1" 191 192 set oldFocus [focus] 193 set oldGrab [grab current $w] 194 if {$oldGrab != ""} { 195 set grabStatus [grab status $oldGrab] 196 } 197 catch {grab $w} 198 199 if {[winfo ismapped $_parent]} { 200 wm withdraw $w 201 wm geometry $w "+[winfo rootx $_parent]+[winfo rooty $_parent]" 202 update idletasks 203 wm deiconify $w 204 } 205 update 206 tk_getDirectory:ShowDir $w $tk_getDirectory(curdir) 207 focus -force $w 208 tkwait variable tk_getDirectory(fini) 209 210 if { $tk_getDirectory(fini) == 1 } { 211 set retval [eval file join [file split $tk_getDirectory(curdir)] \ 212 $tk_getDirectory(seldir)] 213 } else { 214 set retval "" 215 } 216 217 catch {focus $oldFocus} 218 destroy $w 219 if {$oldGrab != ""} { 220 if {$grabStatus == "global"} { 221 grab -global $oldGrab 222 } else { 223 grab $oldGrab 224 } 225 } 226 return $retval 227} 228 229proc tk_getDirectory:ShowDir {w curdir} { 230 global tk_getDirectory 231 232 set tk_getDirectory(curdir) $curdir 233 $w.f1.dir.ent xview moveto 1.0 234 235 set wi [expr [image width tk_getDirectory:b_dir] + 3] 236 set hi [image height tk_getDirectory:b_dir] 237 set maxy [expr [winfo height $w.f2.cv]-$hi] 238 239 set lidir [list] 240 set lifile [list] 241 foreach file [glob -nocomplain $curdir/*] { 242 if [ file isdirectory $file ] { 243 lappend lidir [file tail $file] 244 } else { 245 lappend lifile [file tail $file] 246 } 247 } 248 set sldir [lsort $lidir] 249 250 $w.f2.cv delete all 251 set ind 0 252 set x 2 253 set y 2 254 foreach file $sldir { 255 $w.f2.cv create image $x $y -anchor nw \ 256 -image tk_getDirectory:b_dir -tags IMG 257 $w.f2.cv create text [expr $x+$wi] $y -anchor nw -text $file -tags TXT 258 incr y $hi 259 if {$y >= $maxy} { 260 set bbox [$w.f2.cv bbox all] 261 set x [expr [lindex $bbox 2]+10] 262 set y 2 263 } 264 } 265 if {$tk_getDirectory(showfiles)} { 266 foreach file [lsort $lifile] { 267 $w.f2.cv create image $x $y -anchor nw -image tk_getDirectory:b_file 268 $w.f2.cv create text [expr $x+$wi] $y -anchor nw -text $file 269 incr y $hi 270 if {$y >= $maxy} { 271 set bbox [$w.f2.cv bbox all] 272 set x [expr [lindex $bbox 2]+10] 273 set y 2 274 } 275 } 276 } 277 $w.f2.cv configure -scrollregion [$w.f2.cv bbox all] 278 set tk_getDirectory(seldir) "" 279} 280 281proc tk_getDirectory:UpDir {w} { 282 global tk_getDirectory 283 set curdir $tk_getDirectory(curdir) 284 set curlst [file split $curdir] 285 set nbr [llength $curlst] 286 if {$nbr < 2} return 287 set tmp [expr $nbr - 2] 288 set newlst [ lrange $curlst 0 $tmp ] 289 set newdir [ eval file join $newlst ] 290 tk_getDirectory:ShowDir $w $newdir 291} 292 293proc tk_getDirectory:HighlightItem {w} { 294 global tk_getDirectory 295 catch {$w.f2.cv select clear} 296 set id [$w.f2.cv find withtag current] 297 if {[$w.f2.cv type $id] != "text"} {incr id} 298 $w.f2.cv select from $id 0 299 $w.f2.cv select to $id end 300 set tk_getDirectory(seldir) [$w.f2.cv itemcget $id -text] 301} 302 303proc tk_getDirectory:ClickItem {w} { 304 global tk_getDirectory 305 set id [$w.f2.cv find withtag current] 306 if {[$w.f2.cv type $id] != "text"} {incr id} 307 set dir [$w.f2.cv itemcget $id -text] 308 if {[string length $dir]==0} return 309 tk_getDirectory:ShowDir $w [file join $tk_getDirectory(curdir) $dir] 310} 311 312proc tk_getDirectory:Menu {w} { 313 global tk_getDirectory tcl_platform 314 if {![info exist tk_getDirectory(drives)]} { 315 if {$tcl_platform(platform) == "unix" || 316 [catch {file volume} tk_getDirectory(drives)]} { 317 set tk_getDirectory(drives) {} 318 } 319 if {$tcl_platform(platform) == "windows"} { 320 set tk_getDirectory(drives) [string toupper $tk_getDirectory(drives)] 321 } 322 } 323 set curlst [file split $tk_getDirectory(curdir)] 324 set nbr [llength $curlst] 325 $w.f1.dir.but.m delete 0 last 326 incr nbr -2 327 set tmpdir {} 328 for {set ind $nbr} {$ind >= 0} {incr ind -1} { 329 set tmplst [ lrange $curlst 0 $ind] 330 set tmpdir [ eval file join $tmplst] 331 $w.f1.dir.but.m add command -label $tmpdir \ 332 -command "tk_getDirectory:ShowDir $w [list $tmpdir]" 333 } 334 set rootdir [string toupper $tmpdir] 335 foreach drive $tk_getDirectory(drives) { 336 if {$drive != $rootdir} { 337 $w.f1.dir.but.m add command -label $drive \ 338 -command "tk_getDirectory:ShowDir $w [list $drive]" 339 } 340 } 341} 342 343proc tk_getDirectory:NewDir {wref} { 344 global tcl_platform tk_getDirectory 345 set w .newdir 346 catch {destroy $w} 347 toplevel $w 348 wm title $w "New Folder" 349 wm transient $w $wref 350 351 set f [frame $w.name] 352 pack $f -side top -fill x -padx 5 -pady 5 353 label $f.lab -text "Name:" 354 pack $f.lab -side left 355 entry $f.ent -width 30 356 pack $f.ent -side left -fill x -expand 1 357 $f.ent insert 0 "New Folder" 358 359 set f [frame $w.but] 360 pack $f -side bottom -fill x -padx 5 -pady 5 361 button $f.accept -text Ok -width 6 -default active \ 362 -command {set tk_getDirectory(newdir) 1} 363 bind $w <Return> " 364 $f.accept flash 365 set tk_getDirectory(newdir) 1 366 " 367 button $f.cancel -text Cancel -width 6 \ 368 -command {set tk_getDirectory(newdir) 0} 369 pack $f.accept $f.cancel -side left -expand 1 370 if {$tcl_platform(platform) == "windows"} { 371 $f.accept configure -pady 0 372 $f.cancel configure -pady 0 373 } 374 375 wm withdraw $w 376 wm geometry $w \ 377 "+[expr [winfo rootx $wref.f2.cv]+20]+[expr [winfo rooty $wref.f2.cv]+5]" 378 update idletasks 379 wm deiconify $w 380 381 set oldFocus [focus] 382 set oldGrab [grab current $w] 383 if {$oldGrab != ""} { 384 set grabStatus [grab status $oldGrab] 385 } 386 catch {grab $w} 387 tkwait visibility $w 388 $w.name.ent selection range 0 end 389 focus $w.name.ent 390 tkwait variable tk_getDirectory(newdir) 391 392 if {$tk_getDirectory(newdir)} { 393 set newdir "$tk_getDirectory(curdir)/[string trim [$w.name.ent get]]" 394 } else { 395 set newdir {} 396 } 397 398 catch {focus $oldFocus} 399 destroy $w 400 if {$oldGrab != ""} { 401 if {$grabStatus == "global"} { 402 grab -global $oldGrab 403 } else { 404 grab $oldGrab 405 } 406 } 407 408 if {$newdir != ""} { 409 if {[catch {file mkdir $newdir} msg]} { 410 tk_dialog .error Error $msg error 0 Ok 411 } else { 412 tk_getDirectory:ShowDir $wref $tk_getDirectory(curdir) 413 } 414 } 415} 416 417