diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index 154c65d9a6..802b7880de 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -194,7 +194,7 @@ ;; shift was pressed, so swap role of shifted and unshifted (values s id sa a) (values id s a sa)))) - (values (try-generate-release) #f #f #f)) + (values (and is-up? (try-generate-release)) #f #f #f)) (cond [(and (not is-up?) (= wParam VK_CONTROL)) ;; Don't generate control-key down events: diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 86a389c3f4..73a0751318 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -29,8 +29,11 @@ (send (list-ref menus pos) set-menu-label hmenu pos str) (refresh)) - (def/public-unimplemented number) - (def/public-unimplemented enable-top) + (define/public (number) (length menus)) + + (define/public (enable-top pos on?) + (send (list-ref menus pos) enable-self hmenu pos on?) + (refresh)) (define/public (delete which pos) (atomically diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index db2f8d7a9e..d11d4fac5b 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -102,6 +102,11 @@ (bitwise-ior MF_BYPOSITION (if on? MF_ENABLED MF_GRAYED))))))) + (define/public (enable-self parent-hmenu pos on?) + (EnableMenuItem parent-hmenu pos + (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED)))) + (define/public (check id on?) (with-item id diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 0aa996362b..be571adaf1 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -8,6 +8,7 @@ "const.rkt" "menu-item.rkt" "frame.rkt" + "window.rkt" "dc.rkt" "printer-dc.rkt" "../common/printer.rkt" @@ -60,7 +61,6 @@ check-for-break) (define-unimplemented find-graphical-system-path) -(define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented cancel-quit) (define-unimplemented write-resource) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 72a191ddee..cd449ae6a8 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -20,7 +20,8 @@ (provide window% queue-window-event queue-window-refresh-event - + location->window + GetWindowRect GetClientRect) @@ -54,9 +55,20 @@ (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) +(define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void)) + +(define _HDROP _pointer) +(define-shell32 DragQueryPoint (_wfun _HDROP (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r p (failed 'DragQueryPoint)))) +(define-shell32 DragQueryFileW (_wfun _HDROP _UINT _pointer _UINT -> _UINT)) +(define-shell32 DragFinish (_wfun _HDROP -> _void)) + (define-user32 SetCapture (_wfun _HWND -> _HWND)) (define-user32 ReleaseCapture (_wfun -> _BOOL)) +(define-user32 WindowFromPoint (_fun _POINT -> _HWND)) +(define-user32 GetParent (_fun _HWND -> _HWND)) + (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -171,6 +183,9 @@ (send wx control-scrolled) 0) (default w msg wParam lParam)))] + [(= msg WM_DROPFILES) + (handle-drop-files wParam) + 0] [else (default w msg wParam lParam)]))) @@ -190,8 +205,6 @@ (unless (memq 'deleted style) (show #t)) - (def/public-unimplemented on-drop-file) - (define/public (on-size w h) (void)) (define/public (on-set-focus) (void)) @@ -331,7 +344,21 @@ (set-box! y (POINT-y p)))) (define/public (drag-accept-files on?) - (void)) + (DragAcceptFiles (get-hwnd) on?)) + + (define/private (handle-drop-files wParam) + (let* ([hdrop (cast wParam _WPARAM _HDROP)] + [pt (DragQueryPoint hdrop)] + [count (DragQueryFileW hdrop #xFFFFFFFF #f 0)]) + (for ([i (in-range count)]) + (let* ([len (DragQueryFileW hdrop i #f 0)] + [b (malloc (add1 len) _int16)]) + (DragQueryFileW hdrop i b (add1 len)) + (let ([s (cast b _pointer _string/utf-16)]) + (queue-window-event this (lambda () (on-drop-file (string->path s))))))) + (DragFinish hdrop))) + + (define/public (on-drop-file p) (void)) (define/public (get-position x y) (set-box! x (get-x)) @@ -601,3 +628,11 @@ (define (queue-window-refresh-event win thunk) (queue-refresh-event (send win get-eventspace) thunk)) + +(define (location->window x y) + (let ([hwnd (WindowFromPoint (make-POINT x y))]) + (let loop ([hwnd hwnd]) + (and hwnd + (or (let ([wx (any-hwnd->wx hwnd)]) + (and wx (send wx get-top-frame))) + (loop (GetParent hwnd)))))))