Welcome, guest | Sign In | My Account | Store | Cart

Supporting mouse wheel on vertical scrollbars (Tcl recipe) by Tsahi Levent-Levi
ActiveState Code (http://code.activestate.com/recipes/68394/)

A simple way of adding the mouse's wheel support to a TCL application

Tcl, 31 lines
Download
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
proc wheelEvent { x y delta } {

    # Find out what's the widget we're on
    set act 0
    set widget [winfo containing $x $y]

    if {$widget != ""} {
        # Make sure we've got a vertical scrollbar for this widget
        if {[catch "$widget cget -yscrollcommand" cmd]} return

        if {$cmd != ""} {
            # Find out the scrollbar widget we're using
            set scroller [lindex $cmd 0]

            # Make sure we act
            set act 1
        }
    }

    if {$act == 1} {
        # Now we know we have to process the wheel mouse event
        set xy [$widget yview]
        set factor [expr [lindex $xy 1]-[lindex $xy 0]]

        # Make sure we activate the scrollbar's command
        set cmd "[$scroller cget -command] scroll [expr -int($delta/(120*$factor))] units"
        eval $cmd
    }
}

bind all <MouseWheel> "+wheelEvent %X %Y %D"

This addition allows Windows users to use the wheel of the mouse as they do today in most Windows applications. The procedure written in this example, along with the bind should be insterted with minimum changes to existing code.

Tags: binding

2 comments

Keith Vetter 22 years, 7 months ago  # | flag

Extension so <Shift-MouseWheel> scrolls horizontally.

proc wheelEvent {x y delta {XorY y}} {

    # Get scroll command for this widget
    set widget [winfo containing $x $y]
    if {$widget == ""} return
    if {[catch {set cmd [$widget cget -${XorY}scrollcommand]}]} return
    if {$cmd == ""} return
    set scmd [[lindex $cmd 0] cget -command]

    # NB. Text and Listbox hardcode factor=4
    set xy [$widget ${XorY}view]
    set factor [expr {[lindex $xy 1] - [lindex $xy 0]}]

    # Make sure we activate the scrollbar's command
    set cmd "$scmd scroll [expr -int($delta/(120*$factor))] units"
    eval $cmd
}

bind all  "+wheelEvent %X %Y %D y"
bind all  "+wheelEvent %X %Y %D x"
andreas kupries 22 years, 7 months ago  # | flag

Extension to Unix, Danger note.

# Support for mousewheels on Linux/Unix commonly comes through
# mapping the wheel to the extended buttons. If you have a
# mousewheel, find Linux configuration info at:
#
# http://www.inria.fr/koala/colas/mouse-wheel-scroll/

if {[string equal "unix" $tcl_platform(platform)]} {
    bind all <4> "+wheelEvent %X %Y -5"
    bind all <5> "+wheelEvent %X %Y  5"
}

Note that the bindings as given above are dangerous in the sense that the scrolling of a canvas or text widget used inside of a Megawidget is usually not wanted. Megawidget authors have to take care to disable the bindtags all and class.

Created by Tsahi Levent-Levi on Mon, 10 Sep 2001 (MIT)
◄ Tcl recipes (162) ►
◄ Tsahi Levent-Levi's recipes (1) ►

Required Modules

  • (none specified)

Other Information and Tasks