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

win32: mouse-leave events when mouse leaves the frame

Browse Source 
original commit: 4c05bb48f128c1885c122835eb29755f2a9535b1
This commit is contained in:
Matthew Flatt 2011-01-10 11:26:51 -07:00
parent 8744d5c5b5
commit c54649bd9e
1 changed files with 60 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -116,6 +116,20 @@
[cbData _DWORD] [cbData _DWORD]
[lpData _pointer])) [lpData _pointer]))
(define-cstruct _TRACKMOUSEEVENT
([cbSize _DWORD]
[dwFlags _DWORD]
[hwndTrack _HWND]
[dwHoverTime _DWORD]))
(define TME_LEAVE #x02)
(define TME_NONCLIENT #x10)
(define-user32 TrackMouseEvent (_wfun _TRACKMOUSEEVENT-pointer -> (r : _BOOL)
-> (unless r (failed 'TrackMouseEvent))))
(define-user32 GetCursorPos (_wfun _POINT-pointer -> (r : _BOOL)
-> (unless r (failed 'GetCursorPos))))
(defclass window% object% (defclass window% object%
(init-field parent hwnd) (init-field parent hwnd)
(init style (init style
@ -524,7 +538,11 @@
[(= msg WM_MOUSEMOVE) [(= msg WM_MOUSEMOVE)
(do-mouse w msg #f 'motion wParam lParam)] (do-mouse w msg #f 'motion wParam lParam)]
[(= msg WM_MOUSELEAVE) [(= msg WM_MOUSELEAVE)
(do-mouse w msg #f 'leave wParam lParam)] (let ([p (make-POINT 0 0)])
(GetCursorPos p)
(let ([f (location->window (POINT-x p) (POINT-y p))])
(unless (eq? f (get-top-frame))
(do-mouse w msg #f 'leave wParam lParam))))]
[else #f])) [else #f]))
(define/private (do-mouse control-hwnd msg nc? type wParam lParam) (define/private (do-mouse control-hwnd msg nc? type wParam lParam)
@ -556,28 +574,38 @@
[alt-down #f] [alt-down #f]
[time-stamp 0] [time-stamp 0]
[caps-down #f]))]) [caps-down #f]))])
(unless nc? (if (eq? type 'leave)
(when (wants-mouse-capture? control-hwnd) (let ([t (get-top-frame)])
(when (memq type '(left-down right-down middle-down)) (send t send-child-leaves make-e)
(SetCapture control-hwnd)) (send t send-leaves make-e))
(when (memq type '(left-up right-up middle-up)) (begin
(ReleaseCapture)))) (unless nc?
(if mouse-in? (when (wants-mouse-capture? control-hwnd)
(if (send-child-leaves (lambda (type) (make-e type))) (when (memq type '(left-down right-down middle-down))
(cursor-updated-here) (SetCapture control-hwnd))
(if (send (get-top-frame) is-wait-cursor-on?) (when (memq type '(left-up right-up middle-up))
(void (SetCursor (get-wait-cursor))) (ReleaseCapture))))
(when effective-cursor-handle (if mouse-in?
(void (SetCursor effective-cursor-handle))))) (if (send-child-leaves make-e)
(let ([c (generate-mouse-ins this (lambda (type) (make-e type)))]) (cursor-updated-here)
(when c (if (send (get-top-frame) is-wait-cursor-on?)
(set! effective-cursor-handle c) (void (SetCursor (get-wait-cursor)))
(void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?) (when effective-cursor-handle
(get-wait-cursor) (void (SetCursor effective-cursor-handle)))))
c)))))) (let ([c (generate-mouse-ins this (lambda (type) (make-e type)))])
(when (memq type '(left-down right-down middle-down)) (TrackMouseEvent (make-TRACKMOUSEEVENT
(set-focus)) (ctype-sizeof _TRACKMOUSEEVENT)
(handle-mouse-event control-hwnd msg wParam (make-e type))))) (bitwise-ior TME_LEAVE)
control-hwnd
0))
(when c
(set! effective-cursor-handle c)
(void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?)
(get-wait-cursor)
c))))))
(when (memq type '(left-down right-down middle-down))
(set-focus))
(handle-mouse-event control-hwnd msg wParam (make-e type)))))))
(define/private (handle-mouse-event w msg wParam e) (define/private (handle-mouse-event w msg wParam e)
(if (definitely-wants-event? w msg wParam e) (if (definitely-wants-event? w msg wParam e)
@ -604,14 +632,15 @@
(send parent generate-mouse-ins this mk)) (send parent generate-mouse-ins this mk))
(define/public (send-leaves mk) (define/public (send-leaves mk)
(set! mouse-in? #f) (when mouse-in?
(when mk (set! mouse-in? #f)
(let ([e (mk 'leave)]) (when mk
(if (eq? (current-thread) (let ([e (mk 'leave)])
(eventspace-handler-thread eventspace)) (if (eq? (current-thread)
(handle-mouse-event (get-client-hwnd) 0 0 e) (eventspace-handler-thread eventspace))
(queue-window-event this (handle-mouse-event (get-client-hwnd) 0 0 e)
(lambda () (dispatch-on-event/sync e))))))) (queue-window-event this
(lambda () (dispatch-on-event/sync e))))))))
(define/public (send-child-leaves mk) (define/public (send-child-leaves mk)
#f) #f)