home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / demos / Tktable / command.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  2.1 KB  |  86 lines
  1. #!/bin/sh
  2. # the next line restarts using wish \
  3.     exec wish "$0" ${1+"$@"}
  4.  
  5. ## command.tcl
  6. ##
  7. ## This demo shows the use of the table widget's -command options
  8. ##
  9. ## jeff.hobbs@acm.org
  10.  
  11. source [file join [file dirname [info script]] loadtable.tcl]
  12.  
  13. array set table {
  14.     rows    10
  15.     cols    10
  16.     table    .table
  17.     array    DATA
  18. }
  19.  
  20. proc fill { array x y } {
  21.     upvar $array f
  22.     for {set i -$x} {$i<$x} {incr i} {
  23.     for {set j -$y} {$j<$y} {incr j} { set f($i,$j) "$i x $j" }
  24.     }
  25. }
  26.  
  27. ## Test out the use of a procedure to define tags on rows and columns
  28. proc rowProc row { if {$row>0 && $row%2} { return OddRow } }
  29. proc colProc col { if {$col>0 && $col%2} { return OddCol } }
  30.  
  31. proc tblCmd { arrayName set cell val } {
  32.     upvar \#0 $arrayName data
  33.  
  34.     if {$set} {
  35.     #echo set $cell $val
  36.     set data($cell) $val
  37.     } else {
  38.     #echo get $cell
  39.     if {[info exists data($cell)]} {
  40.         return $data($cell)
  41.     } else {
  42.         return
  43.     }
  44.     }
  45. }
  46.  
  47. label .label -text "TkTable -command Example"
  48. label .current -textvar CURRENT -width 5
  49. entry .active -textvar ACTIVE
  50.  
  51. bind .active <Return> "$table(table) curvalue \[%W get\]"
  52.  
  53. fill $table(array) $table(rows) $table(cols)
  54. set t $table(table)
  55. table $table(table) -rows $table(rows) -cols $table(cols) \
  56.     -command [list tblCmd $table(array) %i %C %s] -cache 1 \
  57.     -width 6 -height 6 \
  58.     -titlerows 1 -titlecols 1 \
  59.     -yscrollcommand {.sy set} -xscrollcommand {.sx set} \
  60.     -roworigin -1 -colorigin -1 \
  61.     -rowtagcommand rowProc -coltagcommand colProc \
  62.     -selectmode extended \
  63.     -rowstretch unset -colstretch unset \
  64.     -flashmode on -browsecommand {
  65.     set CURRENT %S
  66.     set ACTIVE [%W get %S]
  67. } -validate 1 -validatecommand {
  68.     set ACTIVE %S
  69.     return 1
  70. }
  71.  
  72. scrollbar .sy -command [list $table(table) yview] -orient v
  73. scrollbar .sx -command [list $table(table) xview] -orient h
  74. grid .label - - -sticky ew
  75. grid .current .active - -sticky ew
  76. grid $table(table) - .sy -sticky nsew
  77. grid .sx - -sticky ew
  78. grid columnconfig . 1 -weight 1
  79. grid rowconfig . 2 -weight 1
  80.  
  81. $table(table) tag config OddRow -bg orange -fg purple
  82. $table(table) tag config OddCol -bg brown -fg pink
  83.  
  84. puts [list Table is $table(table)]
  85.  
  86.