1# cscroll.tcl -- 2# 3# This demonstration script creates a simple canvas that can be 4# scrolled in two dimensions. 5# 6# RCS: @(#) $Id: cscroll.tcl,v 1.3.4.1 2005/12/13 03:44:42 das Exp $ 7 8if {![info exists widgetDemo]} { 9 error "This script should be run from the \"widget\" demo." 10} 11 12set w .cscroll 13catch {destroy $w} 14toplevel $w 15wm title $w "Scrollable Canvas Demonstration" 16wm iconname $w "cscroll" 17positionWindow $w 18set c $w.c 19 20label $w.msg -font $font -wraplength 4i -justify left -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." 21pack $w.msg -side top 22 23frame $w.buttons 24pack $w.buttons -side bottom -fill x -pady 2m 25button $w.buttons.dismiss -text Dismiss -command "destroy $w" 26button $w.buttons.code -text "See Code" -command "showCode $w" 27pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 28 29frame $w.grid 30scrollbar $w.hscroll -orient horiz -command "$c xview" 31scrollbar $w.vscroll -command "$c yview" 32canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \ 33 -xscrollcommand "$w.hscroll set" \ 34 -yscrollcommand "$w.vscroll set" 35pack $w.grid -expand yes -fill both -padx 1 -pady 1 36grid rowconfig $w.grid 0 -weight 1 -minsize 0 37grid columnconfig $w.grid 0 -weight 1 -minsize 0 38 39grid $c -padx 1 -in $w.grid -pady 1 \ 40 -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news 41grid $w.vscroll -in $w.grid -padx 1 -pady 1 \ 42 -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news 43grid $w.hscroll -in $w.grid -padx 1 -pady 1 \ 44 -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news 45 46 47set bg [lindex [$c config -bg] 4] 48for {set i 0} {$i < 20} {incr i} { 49 set x [expr {-10 + 3*$i}] 50 for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { 51 $c create rect ${x}c ${y}c [expr {$x+2}]c [expr {$y+2}]c \ 52 -outline black -fill $bg -tags rect 53 $c create text [expr {$x+1}]c [expr {$y+1}]c -text "$i,$j" \ 54 -anchor center -tags text 55 } 56} 57 58$c bind all <Any-Enter> "scrollEnter $c" 59$c bind all <Any-Leave> "scrollLeave $c" 60$c bind all <1> "scrollButton $c" 61bind $c <2> "$c scan mark %x %y" 62bind $c <B2-Motion> "$c scan dragto %x %y" 63if {[tk windowingsystem] eq "aqua"} { 64 bind $c <MouseWheel> { 65 %W yview scroll [expr {- (%D)}] units 66 } 67 bind $c <Option-MouseWheel> { 68 %W yview scroll [expr {-10 * (%D)}] units 69 } 70 bind $c <Shift-MouseWheel> { 71 %W xview scroll [expr {- (%D)}] units 72 } 73 bind $c <Shift-Option-MouseWheel> { 74 %W xview scroll [expr {-10 * (%D)}] units 75 } 76} 77 78proc scrollEnter canvas { 79 global oldFill 80 set id [$canvas find withtag current] 81 if {[lsearch [$canvas gettags current] text] >= 0} { 82 set id [expr {$id-1}] 83 } 84 set oldFill [lindex [$canvas itemconfig $id -fill] 4] 85 if {[winfo depth $canvas] > 1} { 86 $canvas itemconfigure $id -fill SeaGreen1 87 } else { 88 $canvas itemconfigure $id -fill black 89 $canvas itemconfigure [expr {$id+1}] -fill white 90 } 91} 92 93proc scrollLeave canvas { 94 global oldFill 95 set id [$canvas find withtag current] 96 if {[lsearch [$canvas gettags current] text] >= 0} { 97 set id [expr {$id-1}] 98 } 99 $canvas itemconfigure $id -fill $oldFill 100 $canvas itemconfigure [expr {$id+1}] -fill black 101} 102 103proc scrollButton canvas { 104 global oldFill 105 set id [$canvas find withtag current] 106 if {[lsearch [$canvas gettags current] text] < 0} { 107 set id [expr {$id+1}] 108 } 109 puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" 110} 111