[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. # # 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.grab_cursor fleur option add *Canvas.ungrab_cursor hand2 option add *a.full_scroll yes # These three are all required to scroll by sticking the # cursor to the drawing. option add *b.full_scroll no option add *b.xScrollIncrement 1 option add *b.yScrollIncrement 1 #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_grab_scroller_bind_motion uwp_p_append_tag GrabScrollerScroll alias uwp_grab_scroller_unbind_motion uwp_p_remove_tag GrabScrollerScroll #page proc uwp_grab_scroller_event_press { widget x y } { uwp_grab_scroller_bind_motion $widget uwp_p_grab_scroller_save_current_pointer_position $widget $x $y uwp_p_grab_scroller_set_grab_cursor $widget } proc uwp_grab_scroller_event_release { widget } { uwp_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 } { foreach {oldX oldY} [uwp_data_get $widget pointer] {} uwp_data_set $widget pointer [list $x $y] if { [option get $widget full_scroll {}] } { $widget xview moveto \ [expr {(double($oldX)-double($x))/double([winfo width $widget])+ double([lindex [$widget xview] 0])}] $widget yview moveto \ [expr {(double($oldY)-double($y))/double([winfo height $widget])+ double([lindex [$widget yview] 0])}] } else { $widget xview scroll [expr {int($oldX-$x)}] units $widget yview scroll [expr {int($oldY-$y)}] units } } #page proc uwp_p_grab_scroller_save_current_pointer_position { widget x y } { uwp_data_set $widget pointer [list $x $y] } 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 grab_cursor {}] } proc uwp_p_grab_scroller_set_ungrab_cursor { widget } { . configure -cursor [option get $widget ungrab_cursor {}] } #page ## ------------------------------------------------------------ ## Let's go. ## ------------------------------------------------------------ main ### end of file # Local Variables: # mode: tcl # End: ---- [[Category Widgets]]