suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: another try for horizontal wheel events

Browse Source
This commit is contained in:
Matthew Flatt 2011-04-03 16:09:11 -06:00
parent 342964b10a
commit 37f9363b90
2 changed files with 15 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/wx/win32/const.rkt
View File

@ -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)

26
collects/mred/private/wx/win32/window.rkt
View File

@ -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)])