]> cvs.zerfleddert.de Git - micropolis/blame - src/tk/library/demos/mkScroll.tcl
Import Micropolis from http://www.donhopkins.com/home/micropolis/
[micropolis] / src / tk / library / demos / mkScroll.tcl
CommitLineData
6a5fa4e0
MG
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
9proc 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
52proc 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
67proc 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
77proc 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}
Impressum, Datenschutz