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     ! 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.