Return to mkScroll.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tk / library / demos

Annotation of micropolis/src/tk/library/demos/mkScroll.tcl, revision 1.1.1.1

1.1       root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.