From 37f9363b9069bca5bbc76a80b89e34cd66b2acc0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 3 Apr 2011 16:09:11 -0600
Subject: [PATCH] win32: another try for horizontal wheel events

---
 collects/mred/private/wx/win32/const.rkt  |  2 +-
 collects/mred/private/wx/win32/window.rkt | 26 ++++++++++++-----------
 2 files changed, 15 insertions(+), 13 deletions(-)

diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt
index a72df0876c..79110a1a60 100644
--- a/collects/mred/private/wx/win32/const.rkt
+++ b/collects/mred/private/wx/win32/const.rkt
@@ -192,7 +192,7 @@
 (define WM_XBUTTONDOWN                  #x020B)
 (define WM_XBUTTONUP                    #x020C)
 (define WM_XBUTTONDBLCLK                #x020D)
-(define WM_MOUSELAST                    #x020D)
+(define WM_MOUSEHWHEEL                  #x020E)
 
 ;; Value for rolling one detent
 (define WHEEL_DELTA                     120)
diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt
index ebb7a1e007..f345d2e122 100644
--- a/collects/mred/private/wx/win32/window.rkt
+++ b/collects/mred/private/wx/win32/window.rkt
@@ -191,19 +191,11 @@
          [(= msg WM_CHAR)
           (do-key w msg wParam lParam #t #f default)]
 	 [(= msg WM_MOUSEWHEEL)
-          (let ([gen-wheels 
-                 (lambda (val down up)
-                   (let ([orig-delta (quotient val WHEEL_DELTA)])
-                     (let loop ([delta (abs orig-delta)])
-                       (unless (zero? delta)
-                         (do-key w msg (if (negative? orig-delta)
-                                           down
-                                           up)
-                                 lParam #f #f void)
-                         (loop (sub1 delta))))))])
-            (gen-wheels (HIWORD wParam) 'wheel-down 'wheel-up)
-            (gen-wheels (LOWORD wParam) 'wheel-left 'wheel-right))
+          (gen-wheels w msg lParam (HIWORD wParam) 'wheel-down 'wheel-up)
 	  0]
+         [(= msg WM_MOUSEHWHEEL) ; Vista and later
+          (gen-wheels w msg lParam (HIWORD wParam) 'wheel-left 'wheel-right)
+          0]
          [(= msg WM_COMMAND)
           (let* ([control-hwnd (cast lParam _LPARAM _HWND)]
                  [wx (any-hwnd->wx control-hwnd)]
@@ -512,6 +504,16 @@
 
   (define/public (get-top-frame)
     (send parent get-top-frame))
+
+  (define/private (gen-wheels w msg lParam val down up)
+    (let ([orig-delta (quotient val WHEEL_DELTA)])
+      (let loop ([delta (abs orig-delta)])
+        (unless (zero? delta)
+          (do-key w msg (if (negative? orig-delta)
+                            down
+                            up)
+                  lParam #f #f void)
+          (loop (sub1 delta))))))
   
   (define/private (do-key w msg wParam lParam is-char? is-up? default)
     (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])