Posted to tcl by mjanssen at Wed Sep 12 09:05:45 GMT 2007view raw

  1. # see tip 171 for origin
  2. # place in Tcl/lib/tcl8/tcl8.5 to use
  3.  
  4. bind Text <MouseWheel> {}
  5.  
  6. proc ::tk::MouseWheel {wFired X Y D {shifted 0}} {
  7. # Set event to check based on call
  8. set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"
  9. # do not double-fire in case the class already has a binding
  10. if {[bind [winfo class $wFired] $evt] ne ""} { return }
  11. # obtain the window the mouse is over
  12. set w [winfo containing $X $Y]
  13. # if we are outside the app, try and scroll the focus widget
  14. if {![winfo exists $w]} { catch {set w [focus]} }
  15. if {[winfo exists $w]} {
  16. if {[bind $w $evt] ne ""} {
  17. # Awkward ... this widget has a MouseWheel binding, but to
  18. # trigger successfully in it, we must give it focus.
  19. catch {focus} old
  20. if {$w ne $old} { focus $w }
  21. event generate $w $evt -rootx $X -rooty $Y -delta $D
  22. if {$w ne $old} { focus $old }
  23. return
  24. }
  25. # aqua and x11/win32 have different delta handling
  26. if {[tk windowingsystem] ne "aqua"} {
  27. set delta [expr {- ($D / 30)}]
  28. } else {
  29. set delta [expr {- ($D)}]
  30. }
  31. # scrollbars have different call conventions
  32. if {[string match "*Scrollbar" [winfo class $w]]} {
  33. catch {tk::ScrollByUnits $w \
  34. [string index [$w cget -orient] 0] $delta}
  35. } else {
  36. set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \
  37. scroll $delta units]
  38. # Walking up to find the proper widget handles cases like
  39. # embedded widgets in a canvas
  40. while {[catch $cmd] && [winfo toplevel $w] ne $w} {
  41. set w [winfo parent $w]
  42. }
  43. }
  44. }
  45. }
  46. bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0]
  47. bind all <Shift-MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 1]
  48. if {[tk windowingsystem] eq "x11"} {
  49. # Support for mousewheels on Linux/Unix commonly comes through
  50. # mapping the wheel to the extended buttons.
  51. bind all <4> [list ::tk::MouseWheel %W %X %Y 120]
  52. bind all <5> [list ::tk::MouseWheel %W %X %Y -120]
  53. }
  54.  
  55. package provide mousewheel 0.1