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

win32 repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-15 12:02:46 -06:00
parent f4e74a8f43
commit 090437c4d9
7 changed files with 34 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -54,19 +54,22 @@
[style style])
(when bitmap?
(let ([hbitmap (bitmap->hbitmap label #:bg #xFFFFFF)])
(let ([hbitmap (bitmap->hbitmap label #:bg (get-button-background))])
(remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(set-control-font font)
(define/public (get-button-background)
#xFFFFFF)
(define/public (auto-size-button label)
(cond
[bitmap?
(auto-size label 0 0 4 4)]
[else
(auto-size label 40 12 12 0)]))
(auto-size label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
(auto-size-button label)
(subclass-control (get-hwnd))

3
collects/mred/private/wx/win32/check-box.rkt
View File

@ -19,6 +19,9 @@
(define/override (get-flags) (bitwise-ior BS_AUTOCHECKBOX))
(define/override (get-button-background)
(GetSysColor COLOR_BTNFACE))
(define/override (auto-size-button label)
(auto-size label 0 0 20 0))

6
collects/mred/private/wx/win32/item.rkt
View File

@ -79,15 +79,15 @@
(define/override (gets-focus?) #t)
;; Retain to avoid GC of the bitmaps:
(define label-hbitmaps null)
(define label-hbitmap #f)
(define/public (remember-label-bitmap hbitmap)
(set! label-hbitmaps (cons hbitmap label-hbitmaps)))
(set! label-hbitmap hbitmap))
(define/public (set-label s)
(if (s . is-a? . bitmap%)
(let ([hbitmap (bitmap->hbitmap s)])
(atomically
(set! label-hbitmaps (list hbitmap))
(set! label-hbitmap hbitmap)
(SendMessageW (get-hwnd)
(get-setimage-message)
IMAGE_BITMAP

4
collects/mred/private/wx/win32/queue.rkt
View File

@ -69,9 +69,9 @@
(atomically (hash-remove! t id))
(let ([msg (malloc-msg)])
(let loop ()
(let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)])
(let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)])
;; Since we called PeekMeessage in a thread other than the
;; event-pump thread, see `other-peek-evt' so the pump
;; event-pump thread, set `other-peek-evt' so the pump
;; knows to check again.
(unless (sync/timeout 0 peek-other-peek-evt)
(semaphore-post other-peek-evt))

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

@ -30,8 +30,7 @@
(inherit auto-size set-control-font
is-enabled-to-root?
subclass-control
set-focus
remember-label-bitmap)
set-focus)
(define callback cb)
(define current-value val)
@ -47,6 +46,8 @@
hInstance
#f))
(define label-bitmaps null)
(define radio-hwnds
(let loop ([y 0] [w 0] [labels labels])
(if (null? labels)
@ -73,17 +74,17 @@
#f)])
(when bitmap?
(let ([hbitmap (bitmap->hbitmap label)])
(remember-label-bitmap hbitmap)
(set! label-bitmaps (cons hbitmap label-bitmaps))
(SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(ShowWindow radio-hwnd SW_SHOW)
(set-control-font font radio-hwnd)
(let-values ([(w h)
(let-values ([(w1 h)
(auto-size label 0 0 20 4 (lambda (w h)
(MoveWindow radio-hwnd 0 (+ y SEP) w h #t)
(values w h)))])
(cons radio-hwnd
(loop (+ y SEP h) (max w h) (cdr labels))))))))
(loop (+ y SEP h) (max w1 w) (cdr labels))))))))
(unless (= val -1)
(SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0))

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

@ -79,6 +79,7 @@
(define theme-hfont #f)
#;
(define-values (dlu-x dlu-y)
(let ([v (GetDialogBaseUnits)])
(values (* 1/4 (bitwise-and v #xFFFF))
@ -108,7 +109,9 @@
(super-new)
(define eventspace (current-eventspace))
(define eventspace (if parent
(send parent get-eventspace)
(current-eventspace)))
(set-hwnd-wx! hwnd this)
(for ([extra-hwnd (in-list extra-hwnds)])
@ -288,7 +291,9 @@
[resize
(lambda (w h) (set-size -11111 -11111 w h))]
#:combine-width [combine-w max]
#:combine-height [combine-h max])
#:combine-height [combine-h max]
#:scale-w [scale-w 1]
#:scale-h [scale-h 1])
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
[dc (make-object bitmap-dc% bm)]
@ -313,8 +318,8 @@
[else
(send measure-dc get-text-extent label #f #t)]))]
[(->int) (lambda (v) (inexact->exact (floor v)))])
(resize (max (->int (+ w dw)) (->int (* dlu-x min-w)))
(max (->int (+ h dh)) (->int (* dlu-y min-h))))))
(resize (->int (* scale-h (max (+ w dw) min-w)))
(->int (* scale-w (max (+ h dh) min-h))))))
(define/public (popup-menu m x y)
(let ([gx (box x)]
@ -431,7 +436,7 @@
(begin
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
#t)
(constrained-reply (get-eventspace)
(constrained-reply eventspace
(lambda () (dispatch-on-char e #t))
#t)))
0
@ -542,7 +547,7 @@
(begin
(queue-window-event this (lambda () (dispatch-on-event/sync e)))
#t)
(constrained-reply (get-eventspace)
(constrained-reply eventspace
(lambda () (dispatch-on-event e #t))
#t)))
@ -565,7 +570,7 @@
(set! mouse-in? #f)
(let ([e (mk 'leave)])
(if (eq? (current-thread)
(eventspace-handler-thread (get-eventspace)))
(eventspace-handler-thread eventspace))
(handle-mouse-event (get-client-hwnd) 0 0 e)
(queue-window-event this
(lambda () (dispatch-on-event/sync e))))))

3
collects/mred/private/wxme/editor-canvas.rkt
View File

@ -406,7 +406,8 @@
(using-admin
(when media
(set-custom-cursor
(and (not out-of-client?)
(and (or (not out-of-client?)
(send event dragging?))
(send media adjust-cursor event))))
(when media
(send media on-event event))))