diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 5be59d27..47eb5333 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -28,6 +28,13 @@ (define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) -> (unless r (failed 'ShowScrollbar)))) +(define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) +(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) +(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) + -> (unless r (failed 'DeleteObject)))) +(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) + -> (when (zero? r) (failed 'FillRect)))) + (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) @@ -149,9 +156,15 @@ (let* ([ps (malloc 128)] [hdc (BeginPaint w ps)]) (unless (positive? paint-suspended) - (unless (do-backing-flush this dc hdc) - (queue-paint)) - (do-backing-flush this dc hdc)) + (let* ([hbrush (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref))]) + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush)) + (unless (do-backing-flush this dc hdc) + (queue-paint)))) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) @@ -250,10 +263,16 @@ (define transparent? (memq 'transparent style)) (define bg-col (make-object color% "white")) + (define bg-colorref #xFFFFFF) (define/public (get-canvas-background) (if transparent? #f bg-col)) - (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (set-canvas-background col) + (atomically + (set! bg-col col) + (set! bg-colorref (make-COLORREF (send col red) + (send col green) + (send col blue))))) (define h-scroll-visible? hscroll?) (define v-scroll-visible? vscroll?) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt index ab98a79f..3af7c172 100644 --- a/collects/mred/private/wx/win32/cursor.rkt +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -107,7 +107,7 @@ 16 16 ai xi)))) + (define/public (ok?) (and handle #t)) (define/public (get-handle) handle) - (def/public-unimplemented ok?) (super-new)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 958cad7d..651be348 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -58,7 +58,7 @@ (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define (register-collecting-blit . args) (void)) -(define-unimplemented unregister-collecting-blit) +(define (unregister-collecting-blit . args) (void)) (define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) (define-unimplemented send-event) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 95ed4e06..20617d4e 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -15,7 +15,7 @@ GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str - GetSysColor GetRValue GetGValue GetBValue + GetSysColor GetRValue GetGValue GetBValue make-COLORREF MoveWindow ShowWindow EnableWindow @@ -59,6 +59,10 @@ (define (GetRValue v) (bitwise-and v #xFF)) (define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) (define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) +(define (make-COLORREF r g b) (bitwise-ior + r + (arithmetic-shift g 8) + (arithmetic-shift b 16))) (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) -> (unless r (failed 'MoveWindow)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 8d519681..a53dfecd 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -22,7 +22,8 @@ queue-window-refresh-event CreateWindowExW - GetWindowRect) + GetWindowRect + GetClientRect) (define (unhide-cursor) (void)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 313f2076..cd40e1b5 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -9,6 +9,7 @@ (provide hInstance DefWindowProcW + background-hbrush hwnd->wx any-hwnd->wx set-hwnd-wx! @@ -87,6 +88,10 @@ (define hInstance (GetModuleHandleW #f)) +(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) + (cpointer-push-tag! p 'HBRUSH) + p)) + (void (RegisterClassW (make-WNDCLASS CS_OWNDC wind-proc 0 @@ -94,9 +99,7 @@ hInstance (LoadIconW #f IDI_APPLICATION) #f - (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) - (cpointer-push-tag! p 'HBRUSH) - p) + background-hbrush #f ; menu "PLTFrame"))) @@ -118,9 +121,7 @@ hInstance #f #f - (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) - (cpointer-push-tag! p 'HBRUSH) - p) + background-hbrush #f ; menu "PLTPanel")))