home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / extra / tkgetdir.tcl < prev   
Encoding:
Text File  |  2000-11-02  |  11.3 KB  |  397 lines
  1. #########################################################
  2. # Directory Selector TCL version 1.3
  3. #
  4. # Daniel Roche, <daniel.roche@bigfoot.com>
  5. #
  6. # thanks to :
  7. #  Cyrille Artho <cartho@netlink.ch> for the 'saving pwd fix'
  8. #  Terry Griffin <terryg@axian.com> for <Return> key bindings on buttons.
  9. #  Kenneth Kehl  <Kenneth.Kehl@marconiastronics.com> for blocking at end of dir tree
  10. #
  11. #########################################################
  12.  
  13.  
  14. #########################################################
  15. # 
  16. # tk_getDirectory [option value ...]
  17. #
  18. #  options are :
  19. #   [-initialdir dir]     display in dir
  20. #   [-title string]       make string title of dialog window
  21. #   [-ok string]          make string the label of OK button
  22. #   [-open string]        make string the label of OPEN button
  23. #   [-cancel string]      make string the label of CANCEL button
  24. #   [-msg1 string]        make string the label of the first directory message
  25. #   [-msg2 string]        make string the label of the second directory message
  26. #
  27. #########################################################
  28.  
  29. namespace eval tkgetdir {
  30.     variable drives
  31.     variable fini
  32.     namespace export tk_getDirectory
  33. }
  34.  
  35. proc tkgetdir::tk_getDirectory {args} {
  36.     global tcl_platform
  37.  
  38.     #
  39.     # arguments
  40.     #
  41.     set _titre "Directory Selector"
  42.     set _ldir Directory:
  43.     set _ldnam "Directory Name:"
  44.     set _open Ok
  45.     set _expand Open
  46.     set _cancel Cancel
  47.     
  48.     set ind 0
  49.     set max [llength $args]
  50.     set pwd [pwd]
  51.     while { $ind < $max } {
  52.     switch -exact -- [lindex $args $ind] {
  53.         "-initialdir" {
  54.         incr ind
  55.         cd [lindex $args $ind]
  56.         incr ind
  57.         }
  58.         "-title" {
  59.         incr ind
  60.         set _titre [lindex $args $ind]
  61.         incr ind
  62.         }
  63.         "-ok" {
  64.         incr ind
  65.         set _open [lindex $args $ind]
  66.         incr ind
  67.         }
  68.         "-open" {
  69.         incr ind
  70.         set _expand [lindex $args $ind]
  71.         incr ind
  72.         }
  73.         "-cancel" {
  74.         incr ind
  75.         set _cancel [lindex $args $ind]
  76.         incr ind
  77.         }
  78.         "-msg1" {
  79.         incr ind
  80.         set _ldir [lindex $args $ind]
  81.         incr ind
  82.         }
  83.         "-msg2" {
  84.         incr ind
  85.         set _ldnam [lindex $args $ind]
  86.         incr ind
  87.         }
  88.         default {
  89.         puts "unknown option [lindex $args $ind]"
  90.         return ""
  91.         }
  92.     }
  93.     }
  94.     
  95.     #
  96.     # variables et data
  97.     #
  98.     set tkgetdir::fini 0
  99.     
  100.     image create bitmap b_up -data "
  101.     #define up_width 31
  102.     #define up_height 23
  103.     static unsigned char up_bits[] = {
  104.     0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80,
  105.     0x00, 0x00, 0x00, 0x80, 0x00, 0x3f, 0x00, 0x80, 0x80, 0x40, 0x00, 0x80,
  106.     0x40, 0x80, 0x00, 0x80, 0xe0, 0xff, 0xff, 0x83, 0x20, 0x00, 0x00, 0x82,
  107.     0x20, 0x04, 0x00, 0x82, 0x20, 0x0e, 0x00, 0x82, 0x20, 0x1f, 0x00, 0x82,
  108.     0x20, 0x04, 0x00, 0x82, 0x20, 0x04, 0x00, 0x82, 0x20, 0x04, 0x00, 0x82,
  109.     0x20, 0xfc, 0x0f, 0x82, 0x20, 0x00, 0x00, 0x82, 0x20, 0x00, 0x00, 0x82,
  110.     0xe0, 0xff, 0xff, 0x83, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80,
  111.     0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80};"
  112.  
  113.     image create bitmap b_dir -background #ffff80 -data "
  114.     #define dir_width 17
  115.     #define dir_height 16
  116.     static unsigned char dir_bits[] = {
  117.     0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, 0x10, 0x02, 0x00,
  118.     0x08, 0x04, 0x00, 0xfc, 0x7f, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00,
  119.     0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00,
  120.     0x04, 0x40, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" \
  121.         -maskdata "
  122.     #define dirm_width 17
  123.     #define dirm_height 16
  124.     static unsigned char dirm_bits[] = {
  125.     0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, 0xf0, 0x03, 0x00,
  126.     0xf8, 0x07, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00,
  127.     0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00,
  128.     0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
  129.         
  130.     switch -exact $tcl_platform(platform) {
  131.     unix {
  132.         font create myfont -family lucida -size 14 -weight bold
  133.     }
  134.     windows {
  135.         font create myfont -family courier -size 12
  136.     }
  137.     }
  138.  
  139.     #
  140.     # widgets
  141.     #
  142.     toplevel .dirsel
  143.     grab set .dirsel
  144.     wm geometry .dirsel 500x250
  145.     wm title .dirsel $_titre
  146.  
  147.     event add <<RetEnt>> <Return> <KP_Enter>
  148.     
  149.     frame .dirsel.f1 -relief flat -borderwidth 0
  150.     frame .dirsel.f2 -relief sunken -borderwidth 2 
  151.     frame .dirsel.f3 -relief flat -borderwidth 0
  152.     frame .dirsel.f4 -relief flat -borderwidth 0
  153.     
  154.     pack .dirsel.f1 -fill x
  155.     pack .dirsel.f2 -fill both -expand 1 -padx 6 -pady 6
  156.     pack .dirsel.f3 -fill x
  157.     pack .dirsel.f4 -fill x
  158.     
  159.     label .dirsel.f1.lab -text $_ldir
  160.     menubutton .dirsel.f1.dir -relief raised -indicatoron 1 -anchor w \
  161.         -menu .dirsel.f1.dir.m
  162.     menu .dirsel.f1.dir.m -tearoff 0
  163.     button .dirsel.f1.up -image b_up -command tkgetdir::UpDir
  164.     bind .dirsel.f1.up <<RetEnt>> {.dirsel.f1.up invoke}
  165.  
  166.     pack .dirsel.f1.up -side right -padx 4 -pady 4
  167.     pack .dirsel.f1.lab -side left -padx 4 -pady 4
  168.     pack .dirsel.f1.dir -side right -padx 4 -pady 4 -fill x -expand 1
  169.     
  170.     canvas .dirsel.f2.cv -borderwidth 0 -yscrollcommand ".dirsel.f2.sb set"
  171.     if ![string compare $tcl_platform(platform) windows] {
  172.     .dirsel.f2.cv configure -background white
  173.     }
  174.     scrollbar .dirsel.f2.sb -command ".dirsel.f2.cv yview"
  175.     set scw 16
  176.     place .dirsel.f2.cv -x 0 -relwidth 1.0 -width [expr -$scw ] -y 0 \
  177.         -relheight 1.0
  178.     place .dirsel.f2.sb -relx 1.0 -x [expr -$scw ] -width $scw -y 0 \
  179.         -relheight 1.0
  180.     unset scw
  181.     
  182.     .dirsel.f2.cv bind TXT <Any-Enter> tkgetdir::EnterItem
  183.     .dirsel.f2.cv bind TXT <Any-Leave> tkgetdir::LeaveItem
  184.     .dirsel.f2.cv bind TXT <Any-Button> tkgetdir::ClickItem
  185.     .dirsel.f2.cv bind TXT <Double-Button> tkgetdir::DoubleClickItem
  186.     .dirsel.f2.cv bind IMG <Any-Enter> tkgetdir::EnterItem
  187.     .dirsel.f2.cv bind IMG <Any-Leave> tkgetdir::LeaveItem
  188.     .dirsel.f2.cv bind IMG <Any-Button> tkgetdir::ClickItem
  189.     .dirsel.f2.cv bind IMG <Double-Button> tkgetdir::DoubleClickItem
  190.     
  191.     label .dirsel.f3.lnam -text $_ldnam
  192.     entry .dirsel.f3.chosen -takefocus 0
  193.     pack .dirsel.f3.lnam -side left -padx 4 -pady 4
  194.     pack .dirsel.f3.chosen -side right -fill x -expand 1 -padx 4 -pady 4
  195.     
  196.     button .dirsel.f4.open -text $_open -command { 
  197.     set tmp [.dirsel.f3.chosen get]
  198.     if [ string length $tmp ] {
  199.         set tkgetdir::fini 1 
  200.     }
  201.     }
  202.     bind .dirsel.f4.open <<RetEnt>> {.dirsel.f4.open invoke}
  203.  
  204.     button .dirsel.f4.expand -text $_expand -command tkgetdir::DownDir
  205.     bind .dirsel.f4.expand <<RetEnt>> {.dirsel.f4.expand invoke}
  206.  
  207.     button .dirsel.f4.cancel -text $_cancel -command { 
  208.     set tkgetdir::fini -1 
  209.     }
  210.     bind .dirsel.f4.cancel <<RetEnt>> {.dirsel.f4.cancel invoke}
  211.     
  212.     pack .dirsel.f4.open .dirsel.f4.expand -side left -padx 10 -pady 4
  213.     pack .dirsel.f4.cancel -side right -padx 10 -pady 4
  214.     
  215.     #
  216.     # realwork
  217.     #
  218.     tkgetdir::ShowDir [pwd]
  219.     
  220.     #
  221.     # wait user
  222.     #
  223.     tkwait variable tkgetdir::fini
  224.  
  225.     if { $tkgetdir::fini == 1 } {
  226.     set curdir [.dirsel.f1.dir cget -text]
  227.     set nnam [.dirsel.f3.chosen get]
  228.     set retval [ file join $curdir $nnam ]
  229.     } else {
  230.     set retval ""
  231.     }
  232.     
  233.     font delete myfont 
  234.     destroy .dirsel
  235.     event delete <<RetEnt>>
  236.     cd $pwd
  237.  
  238.     return $retval
  239. }
  240.  
  241. proc tkgetdir::ShowDir {curdir} {
  242.  
  243.     global tcl_platform
  244.     variable drives 
  245.     
  246.     cd $curdir
  247.     .dirsel.f1.dir configure -text $curdir
  248.     
  249.     set hi1 [font metrics myfont -linespace]
  250.     set hi2 [image height b_dir]
  251.     if { $hi1 > $hi2 } {
  252.     set hi $hi1
  253.     } else {
  254.     set hi $hi2
  255.     }
  256.     set wi1 [image width b_dir]
  257.     incr wi1 4
  258.     set wi2 [winfo width .dirsel.f2.cv]
  259.     
  260.     set lidir [list]
  261.     foreach file [ glob -nocomplain * ] {
  262.     if [ file isdirectory [string trim $file "~"] ] { 
  263.         lappend lidir $file
  264.     }
  265.     }
  266.     set sldir [lsort $lidir]
  267.     
  268.     .dirsel.f2.cv delete all
  269.     set ind 0
  270.     foreach file $sldir {
  271.     if [ file isdirectory $file ] { 
  272.         .dirsel.f2.cv create image 2 [expr $ind * $hi] \
  273.             -anchor nw -image b_dir -tags IMG
  274.         .dirsel.f2.cv create text $wi1 [expr $ind * $hi] \
  275.             -anchor nw -text $file -font myfont -tags TXT
  276.         set ind [ expr $ind + 1 ]
  277.     }
  278.     }
  279.  
  280.     set ha [expr $ind * $hi]
  281.     .dirsel.f2.cv configure -scrollregion [list 0 0 $wi2 $ha]
  282.     
  283.     set curlst [file split $curdir]
  284.     set nbr [llength $curlst]
  285.     
  286.     .dirsel.f1.dir.m delete 0 last
  287.     incr nbr -2
  288.     for {set ind $nbr} {$ind >= 0} {incr ind -1} {
  289.     set tmplst [ lrange $curlst 0 $ind] 
  290.     set tmpdir [ eval file join $tmplst] 
  291.     .dirsel.f1.dir.m add command -label $tmpdir \
  292.         -command "tkgetdir::ShowDir {$tmpdir}"
  293.     }
  294.     if {[info exist drives] == 0} {
  295.     set drives [file volume]
  296.     }
  297.     if ![string compare $tcl_platform(platform) windows] {
  298.     foreach drive $drives {
  299.         .dirsel.f1.dir.m add command -label $drive \
  300.             -command "tkgetdir::ShowDir {$drive}"
  301.     }
  302.     }
  303.     
  304. }
  305.  
  306. proc tkgetdir::UpDir {} {
  307.     set curdir [.dirsel.f1.dir cget -text]
  308.     set curlst [file split $curdir]
  309.     
  310.     set nbr [llength $curlst]
  311.     if { $nbr < 2 } {
  312.     return
  313.     }
  314.     set tmp [expr $nbr - 2]
  315.     
  316.     set newlst [ lrange $curlst 0 $tmp ]
  317.     set newdir [ eval file join $newlst ]
  318.     
  319.     .dirsel.f3.chosen delete 0 end
  320.     tkgetdir::ShowDir $newdir
  321. }
  322.  
  323. proc tkgetdir::DownDir {} {
  324.     set curdir [.dirsel.f1.dir cget -text]
  325.     set nnam [.dirsel.f3.chosen get]
  326.  
  327.     set newdir [ file join $curdir $nnam ]
  328.  
  329.     # change 07/19/99
  330.     # If there are more dirs, permit display of one level down.
  331.     # Otherwise, block display and hilight selection in red.
  332.     set areDirs 0
  333.     foreach f [glob -nocomplain [file join $newdir *]] {
  334.     if {[file isdirectory $f]} {
  335.         set areDirs 1
  336.         break
  337.     }
  338.     }
  339.  
  340.     if {$areDirs} {
  341.     .dirsel.f3.chosen delete 0 end
  342.     tkgetdir::ShowDir $newdir
  343.     } else {
  344.     set id [.dirsel.f2.cv find withtag HASBOX ]
  345.     .dirsel.f2.cv itemconfigure $id -fill #FF0000
  346.     }
  347. }
  348.  
  349. proc tkgetdir::EnterItem {} {
  350.     global tcl_platform
  351.  
  352.     set id [.dirsel.f2.cv find withtag current]
  353.     set wt [.dirsel.f2.cv itemcget $id -tags]
  354.     if {[lsearch -exact $wt IMG] >= 0} {
  355.     set id [.dirsel.f2.cv find above $id]
  356.     }
  357.     if [string compare $tcl_platform(platform) windows] {
  358.     set cocol #00FF00
  359.     } else {
  360.     set cocol #0000FF
  361.     }
  362.     .dirsel.f2.cv itemconfigure $id -fill $cocol
  363. }
  364.  
  365. proc tkgetdir::LeaveItem {} {
  366.     set id [.dirsel.f2.cv find withtag current]
  367.     set wt [.dirsel.f2.cv itemcget $id -tags]
  368.     if {[lsearch -exact $wt IMG] >= 0} {
  369.     set id [.dirsel.f2.cv find above $id]
  370.     }
  371.     .dirsel.f2.cv itemconfigure $id -fill black
  372. }
  373.  
  374. proc tkgetdir::ClickItem {} {
  375.     .dirsel.f2.cv delete BOX
  376.     .dirsel.f2.cv dtag HASBOX HASBOX
  377.     set id [.dirsel.f2.cv find withtag current]
  378.     set wt [.dirsel.f2.cv itemcget $id -tags]
  379.     if {[lsearch -exact $wt IMG] >= 0} {
  380.     set id [.dirsel.f2.cv find above $id]
  381.     }
  382.     set bxr [.dirsel.f2.cv bbox $id]
  383.     .dirsel.f2.cv addtag HASBOX withtag current
  384.     eval .dirsel.f2.cv create rectangle $bxr -fill #a2a2ff -outline #a2a2ff -tags BOX
  385.     .dirsel.f2.cv lower BOX
  386.     set nam [.dirsel.f2.cv itemcget $id -text]
  387.     .dirsel.f3.chosen delete 0 end
  388.     .dirsel.f3.chosen insert 0 $nam
  389. }
  390.  
  391. proc tkgetdir::DoubleClickItem {} {
  392.     set id [.dirsel.f2.cv find withtag current]
  393.     tkgetdir::DownDir
  394. }
  395.  
  396.  
  397.