ttk::spinbox: Add cross-platform MouseWheel bindings.

Factored out [ttk::bindMouseWheel] procedure.

1 files changed, 31 insertions, 5 deletions

diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl
index 1de8ec8..9f3d12d 100644
--- a/library/ttk/utils.tcl
+++ b/library/ttk/utils.tcl
@@ -1,5 +1,5 @@
 #
-# $Id: utils.tcl,v 1.6 2008/01/06 19:16:12 jenglish Exp $
+# $Id: utils.tcl,v 1.7 2008/12/07 21:24:12 jenglish Exp $
 #
 # Utilities for widget implementations.
 #
@@ -251,10 +251,7 @@ proc ttk::copyBindings {from to} {
     }
 }
 
-## Standard mousewheel bindings.
-#
-# Usage: [ttk::copyBindings TtkScrollable $bindtag]
-# adds mousewheel support to a scrollable widget.
+### Mousewheel bindings.
 #
 # Platform inconsistencies:
 #
@@ -278,6 +275,35 @@ proc ttk::copyBindings {from to} {
 # Gtk+ and Qt do not appear to use as large a factor).
 #
 
+## ttk::bindMouseWheel $bindtag $command...
+#	Adds basic mousewheel support to $bindtag.
+#	$command will be passed one additional argument
+#	specifying the mousewheel direction (-1: up, +1: down).
+#
+
+proc ttk::bindMouseWheel {bindtag callback} {
+    switch -- [tk windowingsystem] {
+	x11 {
+	    bind $bindtag <ButtonPress-4> "$callback -1"
+	    bind $bindtag <ButtonPress-5> "$callback +1"
+	}
+	win32 {
+	    bind $bindtag <MouseWheel> [append callback { [expr {-(%D/120)}]}]
+	}
+	aqua {
+	    bind $bindtag <MouseWheel> [append callback { [expr {-(%D)}]} ]
+	}
+    }
+}
+
+## Mousewheel bindings for standard scrollable widgets.
+#
+# Usage: [ttk::copyBindings TtkScrollable $bindtag]
+#
+# $bindtag should be for a widget that supports the
+# standard scrollbar protocol.
+#
+
 switch -- [tk windowingsystem] {
     x11 {
 	bind TtkScrollable <ButtonPress-4>       { %W yview scroll -5 units }