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

win32: control callback fixes

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-12 16:17:09 -06:00
parent 80ce36d30d
commit fbc8d17413
7 changed files with 67 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -74,7 +74,7 @@
(define/override (is-command? cmd)
(= cmd BN_CLICKED))
(define/public (do-command control-hwnd)
(define/public (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%

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

@ -418,7 +418,7 @@
(define/override (is-command? cmd)
(= cmd CBN_SELENDOK))
(define/public (do-command control-hwnd)
(define/public (do-command cmd control-hwnd)
(let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)])
(queue-window-event this (lambda () (on-combo-select i)))))

23
collects/mred/private/wx/win32/choice.rkt
View File

@ -14,6 +14,10 @@
(provide choice%)
(define CBN_DROPDOWN 7)
(define CBN_CLOSEUP 8)
(define CBN_SELENDCANCEL 10)
(define choice%
(class item%
(init parent cb label
@ -62,10 +66,27 @@
(subclass-control hwnd)
(define choice-dropped? #f)
(define/override (ctlproc w msg wParam lParam default)
(cond
[(and choice-dropped?
(or (= msg WM_KEYDOWN)
(= msg WM_KEYUP)
(= msg WM_SYSCHAR)
(= msg WM_CHAR)))
(default w msg wParam lParam)]
[else (super ctlproc w msg wParam lParam default)]))
(define/override (is-command? cmd)
(when (= cmd CBN_DROPDOWN)
(set! choice-dropped? #t))
(when (= cmd CBN_CLOSEUP)
(queue-window-event this (lambda ()
(set! choice-dropped? #f))))
(= cmd CBN_SELENDOK))
(define/public (do-command control-hwnd)
(define/public (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%

19
collects/mred/private/wx/win32/list-box.rkt
View File

@ -25,6 +25,9 @@
(define LBS_EXTENDEDSEL #x0800)
(define LBS_DISABLENOSCROLL #x1000)
(define LBN_SELCHANGE 1)
(define LBN_DBLCLK 2)
(define LB_ERR -1)
(define LB_ADDSTRING #x0180)
@ -88,6 +91,22 @@
(subclass-control hwnd)
(define callback cb)
(define/override (is-command? cmd)
(or (= cmd LBN_SELCHANGE)
(= cmd LBN_DBLCLK)))
(define/public (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%
[event-type (if (= cmd LBN_SELCHANGE)
'list-box
'list-box-dclick)]
[time-stamp (current-milliseconds)])))))
(define num (length choices))
(define/public (number) num)

2
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -105,7 +105,7 @@
(define/override (is-command? cmd)
(= cmd BN_CLICKED))
(define/public (do-command control-hwnd)
(define/public (do-command cmd control-hwnd)
(let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)]
[pos (in-naturals)])
(if (ptr-equal? control-hwnd radio-hwnd)

2
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -115,7 +115,7 @@
(define/override (is-command? cmd)
(= cmd 64985))
(define/public (do-command control-hwnd)
(define/public (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%

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

@ -132,33 +132,32 @@
(default w msg wParam lParam)
(do-key w msg wParam lParam #f #f))]
[(= msg WM_KEYDOWN)
(do-key w msg wParam lParam #f #f)
0]
(do-key w msg wParam lParam #f #f default)]
[(= msg WM_KEYUP)
(do-key w msg wParam lParam #f #t)
0]
(do-key w msg wParam lParam #f #t default)]
[(and (= msg WM_SYSCHAR)
(= wParam VK_MENU))
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key w msg wParam lParam #t #f))]
(do-key w msg wParam lParam #t #f void))]
[(= msg WM_CHAR)
(do-key w msg wParam lParam #t #f)
0]
(do-key w msg wParam lParam #t #f default)]
[(= msg WM_COMMAND)
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
[wx (any-hwnd->wx control-hwnd)])
(if (and wx (send wx is-command? (HIWORD wParam)))
[wx (any-hwnd->wx control-hwnd)]
[cmd (HIWORD wParam)])
(if (and wx (send wx is-command? cmd))
(begin
(send wx do-command control-hwnd)
(send wx do-command cmd control-hwnd)
0)
(default w msg wParam lParam)))]
[(= msg WM_NOTIFY)
(let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
[control-hwnd (NMHDR-hwndFrom nmhdr)]
[wx (any-hwnd->wx control-hwnd)])
(if (and wx (send wx is-command? (LOWORD (NMHDR-code nmhdr))))
[wx (any-hwnd->wx control-hwnd)]
[cmd (LOWORD (NMHDR-code nmhdr))])
(if (and wx (send wx is-command? cmd))
(begin
(send wx do-command control-hwnd)
0)
@ -398,17 +397,18 @@
(define/public (get-top-frame)
(send parent get-top-frame))
(define/private (do-key w msg wParam lParam is-char? is-up?)
(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)])
(and e
(if (and e
(if (definitely-wants-event? w msg wParam e)
(begin
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
#t)
(constrained-reply (get-eventspace)
(lambda () (dispatch-on-char e #t))
#t)))))
#t)))
0
(default w msg wParam lParam))))
(define/public (try-mouse w msg wParam lParam)
(cond