git.zerfleddert.de Git - micropolis/blob - src/tk/library/demos/mkScroll.tcl

   1 # mkScroll w
   2 #
   3 # Create a top-level window containing a simple canvas that can
   4 # be scrolled in two dimensions.
   5 #
   6 # Arguments:
   7 #    w -        Name to use for new top-level window.
   8
   9 proc mkScroll {{w .cscroll}} {
  10     catch {destroy $w}
  11     toplevel $w
  12     dpos $w
  13     wm title $w "Scrollable Canvas Demonstration"
  14     wm iconname $w "Canvas"
  15     wm minsize $w 100 100
  16     set c $w.frame2.c
  17
  18     frame $w.frame1 -relief raised -bd 2
  19     frame $w.frame2 -relief raised -bd 2
  20     button $w.ok -text "OK" -command "destroy $w"
  21     pack append $w $w.frame1 {top fill} $w.ok {bottom pady 10 frame center} \
  22             $w.frame2 {top expand fill}
  23     message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
  24             -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."
  25     pack append $w.frame1 $w.frame1.m {frame center}
  26
  27     canvas $c -scrollregion {-10c -10c 50c 20c}
  28     scrollbar $w.frame2.vscroll  -relief sunken -command "$c yview"
  29     scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview"
  30     pack append $w.frame2 $w.frame2.hscroll {bottom fillx} \
  31             $w.frame2.vscroll {right filly} $c {expand fill}
  32     $c config -xscroll "$w.frame2.hscroll set" -yscroll "$w.frame2.vscroll set"
  33
  34     set bg [lindex [$c config -bg] 4]
  35     for {set i 0} {$i < 20} {incr i} {
  36         set x [expr {-10 + 3*$i}]
  37         for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
  38             $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \
  39                     -outline black -fill $bg -tags rect
  40             $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \
  41                 -anchor center -tags text
  42         }
  43     }
  44
  45     $c bind all <Any-Enter> "scrollEnter $c"
  46     $c bind all <Any-Leave> "scrollLeave $c"
  47     $c bind all <1> "scrollButton $c"
  48     bind $c <2> "$c scan mark %x %y"
  49     bind $c <B2-Motion> "$c scan dragto %x %y"
  50 }
  51
  52 proc scrollEnter canvas {
  53     global oldFill
  54     set id [$canvas find withtag current]
  55     if {[lsearch [$canvas gettags current] text] >= 0} {
  56         set id [expr $id-1]
  57     }
  58     set oldFill [lindex [$canvas itemconfig $id -fill] 4]
  59     if {[winfo screendepth $canvas] > 4} {
  60         $canvas itemconfigure $id -fill SeaGreen1
  61     } else {
  62         $canvas itemconfigure $id -fill black
  63         $canvas itemconfigure [expr $id+1] -fill white
  64     }
  65 }
  66
  67 proc scrollLeave canvas {
  68     global oldFill
  69     set id [$canvas find withtag current]
  70     if {[lsearch [$canvas gettags current] text] >= 0} {
  71         set id [expr $id-1]
  72     }
  73     $canvas itemconfigure $id -fill $oldFill
  74     $canvas itemconfigure [expr $id+1] -fill black
  75 }
  76
  77 proc scrollButton canvas {
  78     global oldFill
  79     set id [$canvas find withtag current]
  80     if {[lsearch [$canvas gettags current] text] < 0} {
  81         set id [expr $id+1]
  82     }
  83     puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]"
  84 }