if {0} { [MM] This is for scrolling a canvas like Acrobat Reader does: with the little hand that drags the document. ---- } # canvas_grab_scrolling.tcl -- # # Part of: Useless Widgets Package # Contents: test script for the grab scrolling # Date: Sun Jan 16, 2005 # # Abstract # # Scrolls a canvas by dragging the mouse. This version makes use # of the "scan" widget subcommand, instead of the "scroll" one. # # Copyright (c) 2005 Marco Maggi # # The author hereby grant permission to use, copy, modify, distribute, # and license this software and its documentation for any purpose, # provided that existing copyright notices are retained in all copies # and that this notice is included verbatim in any distributions. No # written agreement, license, or royalty fee is required for any of the # authorized uses. Modifications to this software may be copyrighted by # their authors and need not follow the licensing terms described here, # provided that the new terms are clearly indicated on the first page of # each file where they apply. # # IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY # DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAVE BEEN ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. # # THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND # NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, # AND THE AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. # # #page ## ------------------------------------------------------------ ## Setup. ## ------------------------------------------------------------ package require Tcl 8.4 package require Tk 8.4 #page ## ------------------------------------------------------------ ## Widget options. ## ------------------------------------------------------------ option add *borderWidth 1 option add *Canvas.uwp_grab_scroller_grab_cursor fleur option add *Canvas.uwp_grab_scroller_ungrab_cursor hand2 # Possible values: quick_scroll, sticky_mouse, an integer # selecting the "gain" directly (see the canvas man page, # "scan dragto" subcommand). option add *a.uwp_grab_scroller_gain quick_scroll option add *b.uwp_grab_scroller_gain sticky_mouse #page ## ------------------------------------------------------------ ## Main. ## ------------------------------------------------------------ proc main {} { global exit_trigger wm title . "Canvas Grab Scrolling" wm geometry . +200+100 grid [frame .f] -sticky news canvas [set a .f.a] -width 300 -height 300 -background white canvas [set b .f.b] -width 300 -height 300 -background white grid $a $b -sticky news -padx 5 put_rectangles $a put_rectangles $b uwp_grab_scroller_bind $a uwp_grab_scroller_bind $b grid [button .quit -text Exit -command main_exit] focus .quit bind .quit main_exit bind . main_exit interp alias {} main_exit {} set exit_trigger 1 vwait exit_trigger exit } proc put_rectangles { c } { set max [expr {2*[$c cget -width]}] for {set i 0} {$i < 15} {incr i} { $c create rectangle \ [set x [expr {10*$i*2}]] $x [set y [expr {$max-$x}]] $y } $c create line 0 0 $max $max $c create line 0 $max $max 0 $c configure -scrollregion [list 0 0 $max $max] } #page proc uwp_data_set { widget key value } { global uwp_data set uwp_data($widget:$key) $value } proc uwp_data_get { widget key } { global uwp_data return $uwp_data($widget:$key) } proc uwp_p_append_tag { tag widget } { bindtags $widget [linsert [bindtags $widget] end $tag] } proc uwp_p_remove_tag { tag widget } { set idx [lsearch [set ell [bindtags $widget]] $tag] bindtags $widget [lreplace $ell $idx $idx] } proc alias { alias args } { eval { interp alias {} $alias {} } $args } #page bind GrabScroller { uwp_grab_scroller_event_press %W %x %y } bind GrabScroller { uwp_grab_scroller_event_release %W } bind GrabScroller { uwp_grab_scroller_event_enter %W } bind GrabScroller { uwp_grab_scroller_event_leave %W } bind GrabScrollerScroll { uwp_grab_scroller_event_motion %W %x %y } alias uwp_grab_scroller_bind uwp_p_append_tag GrabScroller alias uwp_grab_scroller_unbind uwp_p_remove_tag GrabScroller alias uwp_p_grab_scroller_bind_motion uwp_p_append_tag GrabScrollerScroll alias uwp_p_grab_scroller_unbind_motion uwp_p_remove_tag GrabScrollerScroll #page proc uwp_grab_scroller_event_press { widget x y } { uwp_p_grab_scroller_bind_motion $widget uwp_p_grab_scroller_set_grab_cursor $widget $widget scan mark $x $y } proc uwp_grab_scroller_event_release { widget } { uwp_p_grab_scroller_unbind_motion $widget uwp_p_grab_scroller_set_ungrab_cursor $widget } proc uwp_grab_scroller_event_enter { widget } { uwp_p_grab_scroller_save_current_cursor $widget uwp_p_grab_scroller_set_ungrab_cursor $widget } proc uwp_grab_scroller_event_leave { widget } { uwp_p_grab_scroller_restore_current_cursor $widget } proc uwp_grab_scroller_event_motion { widget x y } { switch -exact -- [set gain [option get $widget uwp_grab_scroller_gain {}]] { sticky_mouse { set gain 1 } quick_scroll { set gain [expr {[winfo width $widget]/8}] } default { if { [string length $gain] == 0 } { set gain 10 } } } $widget scan dragto $x $y $gain } proc uwp_p_grab_scroller_save_current_cursor { widget } { uwp_data_set $widget oldCursor [. cget -cursor] } proc uwp_p_grab_scroller_restore_current_cursor { widget } { . configure -cursor [uwp_data_get $widget oldCursor] } proc uwp_p_grab_scroller_set_grab_cursor { widget } { . configure -cursor [option get $widget uwp_grab_scroller_grab_cursor {}] } proc uwp_p_grab_scroller_set_ungrab_cursor { widget } { . configure -cursor [option get $widget uwp_grab_scroller_ungrab_cursor {}] } #page ## ------------------------------------------------------------ ## Let's go. ## ------------------------------------------------------------ main ### end of file # Local Variables: # mode: tcl # End: ---- [Category GUI]