7 

     8 

     9 # Modified version of Tip 171:

    10 # http://www.tcl.tk/cgi-bin/tct/tip/171.html

    11 #

    12 # The in_mousewheel global was added to fix strange reentrancy issues.

    13 # The whole snipped is activated only under windows, mouse wheel

    14 # bindings working already under MacOSX and Linux.

    15 

    16 if {[tk windowingsystem] eq "win32"} {

    17 

    18 set mw_classes [list Text Listbox Table TreeCtrl]

    19    foreach class $mw_classes { bind $class <MouseWheel> {} }

    20 

    21 set in_mousewheel 0

    22 

    23 proc ::tk::MouseWheel {wFired X Y D {shifted 0}} {

    24     global in_mousewheel

    25     if { $in_mousewheel != 0 } { return }

    26     # Set event to check based on call

    27     set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"

    28     # do not double-fire in case the class already has a binding

    29     if {[bind [winfo class $wFired] $evt] ne ""} { return }

    30     # obtain the window the mouse is over

    31     set w [winfo containing $X $Y]

    32     # if we are outside the app, try and scroll the focus widget

    33     if {![winfo exists $w]} { catch {set w [focus]} }

    34     if {[winfo exists $w]} {

    35         

    36         if {[bind $w $evt] ne ""} {

    37             # Awkward ... this widget has a MouseWheel binding, but to

    38             # trigger successfully in it, we must give it focus.

    39             catch {focus} old

    40             if {$w ne $old} { focus $w }

    41             set in_mousewheel 1

    42             event generate $w $evt -rootx $X -rooty $Y -delta $D

    43             set in_mousewheel 0

    44             if {$w ne $old} { focus $old }

    45             return

    46         }

    47 

    48         # aqua and x11/win32 have different delta handling

    49         if {[tk windowingsystem] ne "aqua"} {

    50             set delta [expr {- ($D / 30)}]

    51         } else {

    52             set delta [expr {- ($D)}]

    53         }

    54         # scrollbars have different call conventions

    55         if {[string match "*Scrollbar" [winfo class $w]]} {

    56             catch {tk::ScrollByUnits $w \

    57                        [string index [$w cget -orient] 0] $delta}

    58         } else {

    59             set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \

    60                          scroll $delta units]

    61             # Walking up to find the proper widget (handles cases like

    62             # embedded widgets in a canvas)

    63             while {[catch $cmd] && [winfo toplevel $w] ne $w} {

    64                 set w [winfo parent $w]

    65             }

    66         }

    67     }

    68 }

    69 

    70 bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0]

    71 

    72 # end of win32 section

    73 } 

    74