Version 2 of Canvas scrolling by dragging mouse

Updated 2005-01-17 11:54:13 by dkf

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 <Return> main_exit
     bind . <Escape> 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 <ButtonPress-1>        { uwp_grab_scroller_event_press %W %x %y }
 bind GrabScroller <ButtonRelease-1>        { uwp_grab_scroller_event_release %W }
 bind GrabScroller <Enter>                { uwp_grab_scroller_event_enter %W }
 bind GrabScroller <Leave>                { uwp_grab_scroller_event_leave %W }
 bind GrabScrollerScroll <Motion>        { 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:

Hmm, how is this different from simple panning? I use these lines for panning a canvas with the mouse:

   # .c is a canvas, panning works using the left mouse button
   bind .c <ButtonPress-1> {%W scan mark %x %y}
   bind .c <B1-Motion> {%W scan dragto %x %y 1}

DKF: It's about selecting an area by drawing a box around it.


Category GUI