diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index ca693a9b07..f7a2dc97c3 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -98,7 +98,7 @@ (lambda (w h) (check-range-integer '(method top-level-window<%> resize) w) (check-range-integer '(method top-level-window<%> resize) h) - (send wx set-size -1 -1 w h)))] + (send wx set-size -11111 -11111 w h)))] [get-focus-window (entry-point (lambda () (let ([w (send wx get-focus-window)]) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 47eb533352..8f2c5351ea 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -380,6 +380,9 @@ (let loop () (pre-event-sync #t) (when (yield) (loop)))) (void)))))) + (define/override (wants-mouse-capture? control-hwnd) + (ptr-equal? canvas-hwnd control-hwnd)) + (define/override (definitely-wants-event? w msg wParam e) (cond [(e . is-a? . key-event%) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 030cd0dce6..fc336ffdd4 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -234,6 +234,13 @@ (set! mouse-frame this)) #f) + (define/override (send-child-leaves mk) + (if (eq? mouse-frame this) + (if saved-child + (send saved-child send-leaves mk) + #f) + #f)) + (define/override (reset-cursor default) (if wait-cursor-on? (void (SetCursor (get-wait-cursor))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index a72d002785..a0af26eaf4 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -31,13 +31,29 @@ (define IMAGE_ICON 1) (define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON)) +(define-kernel32 GetModuleFileNameW (_wfun _pointer _pointer _DWORD -> _DWORD)) + +(define-shell32 ExtractIconW (_wfun _HINSTANCE _string/utf-16 _UINT -> (r : _HICON) + -> (or r (failed 'ExtractIconW)))) + +(define ERROR_INSUFFICIENT_BUFFER 122) (define app-icon (delay (let () - ;; GetModuleFileNameW(NULL, name, 1023); - ;; icn = ExtractIconW(NULL, name, 0); - (LoadIconW #f IDI_APPLICATION)))) + (let ([path + (let loop ([size 1024]) + (let ([p (make-bytes (* (ctype-sizeof _WCHAR) 1024))]) + (let ([r (GetModuleFileNameW #f p size)]) + (cond + [(and (or (zero? r) (= r size)) + (= (GetLastError) ERROR_INSUFFICIENT_BUFFER)) + (loop (* size 2))] + [(zero? r) (failed 'GetModuleFileNameW)] + [else (cast p _gcpointer _string/utf-16)]))))]) + (if path + (ExtractIconW hInstance path 0) + (LoadIconW #f IDI_APPLICATION)))))) (define warning-icon (delay (LoadIconW #f IDI_WARNING))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 295e4584d2..1a3ffbd54e 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -1,5 +1,6 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "window.rkt" "wndclass.rkt" @@ -13,7 +14,8 @@ (define (panel-mixin %) (class % (inherit is-enabled-to-root? - reset-cursor-in-child) + reset-cursor-in-child + get-client-hwnd) (super-new) @@ -64,6 +66,9 @@ #t) #f)) + (define/override (wants-mouse-capture? control-hwnd) + (ptr-equal? (get-client-hwnd) control-hwnd)) + (define lbl-pos 'horizontal) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 94378acf5e..23e36a79e9 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -97,7 +97,10 @@ (define tab-height 0) (set-control-font #f) - (auto-size choices 0 0 0 0 #:combine-width + + (auto-size (if (null? choices) + '("Choice") + choices) + 0 0 0 0 #:combine-width + (lambda (w h) (set! tab-height (+ h 6)) (set-size -11111 -11111 diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 70786d9d5b..8847b4b5f1 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -8,10 +8,12 @@ define-user32 define-kernel32 define-comctl32 + define-shell32 define-uxtheme define-mz failed + GetLastError CreateWindowExW GetWindowLongW SetWindowLongW @@ -34,12 +36,14 @@ (define user32-lib (ffi-lib "user32.dll")) (define kernel32-lib (ffi-lib "kernel32.dll")) (define comctl32-lib (ffi-lib "comctl32.dll")) +(define shell32-lib (ffi-lib "shell32.dll")) (define uxtheme-lib (ffi-lib "uxtheme.dll")) (define-ffi-definer define-gdi32 gdi32-lib) (define-ffi-definer define-user32 user32-lib) (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-shell32 shell32-lib) (define-ffi-definer define-uxtheme uxtheme-lib) (define-kernel32 GetLastError (_wfun -> _DWORD)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 29fe8829a6..06d37e61b0 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -54,6 +54,9 @@ (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) +(define-user32 SetCapture (_wfun _HWND -> _HWND)) +(define-user32 ReleaseCapture (_wfun -> _BOOL)) + (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -248,7 +251,7 @@ (let ([r (GetWindowRect hwnd)]) (MoveWindow hwnd (if (= x -11111) (RECT-left r) x) - (if (= y -11111) (RECT-right r) y) + (if (= y -11111) (RECT-top r) y) (if (= w -1) (- (RECT-right r) (RECT-left r)) w) (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) #t)) @@ -480,6 +483,12 @@ [alt-down #f] [time-stamp 0] [caps-down #f]))]) + (unless nc? + (when (wants-mouse-capture? control-hwnd) + (when (memq type '(left-down right-down middle-down)) + (SetCapture control-hwnd)) + (when (memq type '(left-up right-up middle-up)) + (ReleaseCapture)))) (if mouse-in? (if (send-child-leaves (lambda (type) (make-e type))) (cursor-updated-here) @@ -532,6 +541,9 @@ (define/public (send-child-leaves mk) #f) + (define/public (wants-mouse-capture? control-hwnd) + #f) + (define/public (definitely-wants-event? w msg wParam e) #f)