Posted to tcl by de at Wed Mar 19 00:37:18 GMT 2008view raw

  1. proc MouseWheel {wFired D X Y} {
  2. # do not double-fire in case the class already has a binding
  3. if {[bind [winfo class $wFired] <MouseWheel>] ne ""} { return }
  4. # obtain the window the mouse is over
  5. set w [winfo containing $X $Y]
  6. # if we are outside the app, try and scroll the focus widget
  7. if {![winfo exists $w]} { catch {set w [focus]} }
  8. if {[winfo exists $w]} {
  9. # scrollbars have different call conventions
  10. if {[winfo class $w] eq "Scrollbar"} {
  11. catch {tk::ScrollByUnits $w \
  12. [string index [$w cget -orient] 0] \
  13. [expr {-($D/30)}]}
  14. } else {
  15. while {$w ne ""} {
  16. if {[lsearch $::mw_classes [winfo class $w]] > -1} {
  17. if {[$w cget -yscrollcommand] eq ""} {
  18. set w [winfo parent $w]
  19. continue
  20. }
  21. catch {$w yview scroll [expr {- ($D / 120) * 4}] units}
  22. break
  23. }
  24. set w [winfo parent $w]
  25. }
  26. }
  27. }
  28. }
  29.  
  30.  
  31. set ::mw_classes [list Text Canvas Listbox Table TreeCtrl]
  32. foreach class $::mw_classes { bind $class <MouseWheel> {} }
  33. if {[tk windowingsystem] eq "x11"} {
  34. foreach class $::mw_classes {
  35. bind $class <4> {}
  36. bind $class <5> {}
  37. }
  38. }
  39.  
  40. bind all <MouseWheel> [list MouseWheel %W %D %X %Y]
  41. if {[tk windowingsystem] eq "x11"} {
  42. # Support for mousewheels on Linux/Unix commonly comes through
  43. # mapping the wheel to the extended buttons.
  44. bind all <4> [list MouseWheel %W 120 %X %Y]
  45. bind all <5> [list MouseWheel %W -120 %X %Y]
  46. }
  47.  
  48.