diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 75639f4c6a..a8581ac2b4 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -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% diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index eb374ca6f1..24722e4c54 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -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))))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 2526a8d873..a9de92b2ea 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -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% diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 20a5760200..ba12082f8c 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 41db4c265c..926f685c93 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 23e36a79e9..9e01b2591c 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -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% diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index b231db0b7e..24a00f023d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -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 (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))))) - + (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))) + 0 + (default w msg wParam lParam)))) (define/public (try-mouse w msg wParam lParam) (cond