Posted to tcl by de at Wed Mar 19 00:37:18 GMT 2008view raw
- proc MouseWheel {wFired D X Y} {
- # do not double-fire in case the class already has a binding
- if {[bind [winfo class $wFired] <MouseWheel>] ne ""} { return }
- # obtain the window the mouse is over
- set w [winfo containing $X $Y]
- # if we are outside the app, try and scroll the focus widget
- if {![winfo exists $w]} { catch {set w [focus]} }
- if {[winfo exists $w]} {
- # scrollbars have different call conventions
- if {[winfo class $w] eq "Scrollbar"} {
- catch {tk::ScrollByUnits $w \
- [string index [$w cget -orient] 0] \
- [expr {-($D/30)}]}
- } else {
- while {$w ne ""} {
- if {[lsearch $::mw_classes [winfo class $w]] > -1} {
- if {[$w cget -yscrollcommand] eq ""} {
- set w [winfo parent $w]
- continue
- }
- catch {$w yview scroll [expr {- ($D / 120) * 4}] units}
- break
- }
- set w [winfo parent $w]
- }
- }
- }
- }
- set ::mw_classes [list Text Canvas Listbox Table TreeCtrl]
- foreach class $::mw_classes { bind $class <MouseWheel> {} }
- if {[tk windowingsystem] eq "x11"} {
- foreach class $::mw_classes {
- bind $class <4> {}
- bind $class <5> {}
- }
- }
- bind all <MouseWheel> [list MouseWheel %W %D %X %Y]
- if {[tk windowingsystem] eq "x11"} {
- # Support for mousewheels on Linux/Unix commonly comes through
- # mapping the wheel to the extended buttons.
- bind all <4> [list MouseWheel %W 120 %X %Y]
- bind all <5> [list MouseWheel %W -120 %X %Y]
- }