3 # Create a top-level window containing a simple canvas that can
4 # be scrolled in two dimensions.
7 # w - Name to use for new top-level window.
9 proc mkScroll
{{w .cscroll
}} {
13 wm title
$w "Scrollable Canvas Demonstration"
14 wm iconname
$w "Canvas"
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
}
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"
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
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"
52 proc scrollEnter
canvas {
54 set id
[$canvas find withtag current
]
55 if {[lsearch [$canvas gettags current
] text] >= 0} {
58 set oldFill
[lindex [$canvas itemconfig
$id -fill] 4]
59 if {[winfo screendepth
$canvas] > 4} {
60 $canvas itemconfigure
$id -fill SeaGreen1
62 $canvas itemconfigure
$id -fill black
63 $canvas itemconfigure
[expr $id+1] -fill white
67 proc scrollLeave
canvas {
69 set id
[$canvas find withtag current
]
70 if {[lsearch [$canvas gettags current
] text] >= 0} {
73 $canvas itemconfigure
$id -fill $oldFill
74 $canvas itemconfigure
[expr $id+1] -fill black
77 proc scrollButton
canvas {
79 set id
[$canvas find withtag current
]
80 if {[lsearch [$canvas gettags current
] text] < 0} {
83 puts stdout
"You buttoned at [lindex [$canvas itemconf $id -text] 4]"