home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / demos / cscroll.tcl < prev    next >
Text File  |  1999-07-27  |  3KB  |  93 lines
  1. # cscroll.tcl --
  2. #
  3. # This demonstration script creates a simple canvas that can be
  4. # scrolled in two dimensions.
  5. #
  6. # SCCS: @(#) cscroll.tcl 1.5 96/10/04 17:09:36
  7.  
  8. set w .cscroll
  9. catch {destroy $w}
  10. toplevel $w
  11. wm title $w "Scrollable Canvas Demonstration"
  12. wm iconname $w "cscroll"
  13. positionWindow $w
  14. set c $w.c
  15.  
  16. label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas.  If you click button 1 on one of the rectangles, its indices will be printed on stdout."
  17. pack $w.msg -side top
  18.  
  19. frame $w.buttons
  20. pack $w.buttons -side bottom -fill x -pady 2m
  21. button $w.buttons.dismiss -text Dismiss -command "destroy $w"
  22. button $w.buttons.code -text "See Code" -command "showCode $w"
  23. pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
  24.  
  25. frame $w.grid
  26. scrollbar $w.hscroll -orient horiz -command "$c xview"
  27. scrollbar $w.vscroll -command "$c yview"
  28. canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \
  29.     -xscrollcommand "$w.hscroll set" \
  30.     -yscrollcommand "$w.vscroll set"
  31. pack $w.grid -expand yes -fill both -padx 1 -pady 1
  32. grid rowconfig    $w.grid 0 -weight 1 -minsize 0
  33. grid columnconfig $w.grid 0 -weight 1 -minsize 0
  34.  
  35. grid $c -padx 1 -in $w.grid -pady 1 \
  36.     -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
  37. grid $w.vscroll -in $w.grid -padx 1 -pady 1 \
  38.     -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
  39. grid $w.hscroll -in $w.grid -padx 1 -pady 1 \
  40.     -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
  41.  
  42.  
  43. set bg [lindex [$c config -bg] 4]
  44. for {set i 0} {$i < 20} {incr i} {
  45.     set x [expr {-10 + 3*$i}]
  46.     for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
  47.     $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \
  48.         -outline black -fill $bg -tags rect
  49.     $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \
  50.         -anchor center -tags text
  51.     }
  52. }
  53.  
  54. $c bind all <Any-Enter> "scrollEnter $c"
  55. $c bind all <Any-Leave> "scrollLeave $c"
  56. $c bind all <1> "scrollButton $c"
  57. bind $c <2> "$c scan mark %x %y"
  58. bind $c <B2-Motion> "$c scan dragto %x %y"
  59.  
  60. proc scrollEnter canvas {
  61.     global oldFill
  62.     set id [$canvas find withtag current]
  63.     if {[lsearch [$canvas gettags current] text] >= 0} {
  64.     set id [expr $id-1]
  65.     }
  66.     set oldFill [lindex [$canvas itemconfig $id -fill] 4]
  67.     if {[winfo depth $canvas] > 1} {
  68.     $canvas itemconfigure $id -fill SeaGreen1
  69.     } else {
  70.     $canvas itemconfigure $id -fill black
  71.     $canvas itemconfigure [expr $id+1] -fill white
  72.     }
  73. }
  74.  
  75. proc scrollLeave canvas {
  76.     global oldFill
  77.     set id [$canvas find withtag current]
  78.     if {[lsearch [$canvas gettags current] text] >= 0} {
  79.     set id [expr $id-1]
  80.     }
  81.     $canvas itemconfigure $id -fill $oldFill
  82.     $canvas itemconfigure [expr $id+1] -fill black
  83. }
  84.  
  85. proc scrollButton canvas {
  86.     global oldFill
  87.     set id [$canvas find withtag current]
  88.     if {[lsearch [$canvas gettags current] text] < 0} {
  89.     set id [expr $id+1]
  90.     }
  91.     puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]"
  92. }
  93.