home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tk8.4 / demos / cscroll.tcl < prev    next >
Text File  |  2001-06-14  |  3KB  |  97 lines
  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 2001/06/14 10:56:58 dkf Exp $
  7.  
  8. if {![info exists widgetDemo]} {
  9.     error "This script should be run from the \"widget\" demo."
  10. }
  11.  
  12. set w .cscroll
  13. catch {destroy $w}
  14. toplevel $w
  15. wm title $w "Scrollable Canvas Demonstration"
  16. wm iconname $w "cscroll"
  17. positionWindow $w
  18. set c $w.c
  19.  
  20. label $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."
  21. pack $w.msg -side top
  22.  
  23. frame $w.buttons
  24. pack $w.buttons -side bottom -fill x -pady 2m
  25. button $w.buttons.dismiss -text Dismiss -command "destroy $w"
  26. button $w.buttons.code -text "See Code" -command "showCode $w"
  27. pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
  28.  
  29. frame $w.grid
  30. scrollbar $w.hscroll -orient horiz -command "$c xview"
  31. scrollbar $w.vscroll -command "$c yview"
  32. canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \
  33.     -xscrollcommand "$w.hscroll set" \
  34.     -yscrollcommand "$w.vscroll set"
  35. pack $w.grid -expand yes -fill both -padx 1 -pady 1
  36. grid rowconfig    $w.grid 0 -weight 1 -minsize 0
  37. grid columnconfig $w.grid 0 -weight 1 -minsize 0
  38.  
  39. grid $c -padx 1 -in $w.grid -pady 1 \
  40.     -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
  41. grid $w.vscroll -in $w.grid -padx 1 -pady 1 \
  42.     -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
  43. grid $w.hscroll -in $w.grid -padx 1 -pady 1 \
  44.     -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
  45.  
  46.  
  47. set bg [lindex [$c config -bg] 4]
  48. for {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"
  61. bind $c <2> "$c scan mark %x %y"
  62. bind $c <B2-Motion> "$c scan dragto %x %y"
  63.  
  64. proc scrollEnter canvas {
  65.     global oldFill
  66.     set id [$canvas find withtag current]
  67.     if {[lsearch [$canvas gettags current] text] >= 0} {
  68.     set id [expr {$id-1}]
  69.     }
  70.     set oldFill [lindex [$canvas itemconfig $id -fill] 4]
  71.     if {[winfo depth $canvas] > 1} {
  72.     $canvas itemconfigure $id -fill SeaGreen1
  73.     } else {
  74.     $canvas itemconfigure $id -fill black
  75.     $canvas itemconfigure [expr {$id+1}] -fill white
  76.     }
  77. }
  78.  
  79. proc scrollLeave canvas {
  80.     global oldFill
  81.     set id [$canvas find withtag current]
  82.     if {[lsearch [$canvas gettags current] text] >= 0} {
  83.     set id [expr {$id-1}]
  84.     }
  85.     $canvas itemconfigure $id -fill $oldFill
  86.     $canvas itemconfigure [expr {$id+1}] -fill black
  87. }
  88.  
  89. proc scrollButton canvas {
  90.     global oldFill
  91.     set id [$canvas find withtag current]
  92.     if {[lsearch [$canvas gettags current] text] < 0} {
  93.     set id [expr {$id+1}]
  94.     }
  95.     puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]"
  96. }
  97.