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

win32: bitmap+string button labels

Browse Source
This commit is contained in:
Matthew Flatt 2011-01-01 13:40:21 -07:00
parent 241bb79cb0
commit a6e04695bb
1 changed files with 22 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,7 +27,10 @@
(define callback cb) (define callback cb)
(define bitmap? (label . is-a? . bitmap%)) (define bitmap? (or (label . is-a? . bitmap%)
(pair? label)))
(define orientation (and (pair? label)
(caddr label)))
(define/public (get-class) "PLTBUTTON") (define/public (get-class) "PLTBUTTON")
(define/public (get-flags) BS_PUSHBUTTON) (define/public (get-flags) BS_PUSHBUTTON)
@ -37,12 +40,18 @@
[hwnd [hwnd
(CreateWindowExW/control 0 (CreateWindowExW/control 0
(get-class) (get-class)
(if (string? label) (cond
label [(string? label) label]
"<image>") [(pair? label) (cadr label)]
[else "<image>"])
(bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
(if bitmap? (if bitmap?
BS_BITMAP (case orientation
[(#f) BS_BITMAP]
[(left) BS_RIGHT]
[(right) BS_LEFT]
[(top) BS_BOTTOM]
[(bottom) BS_TOP])
0)) 0))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
@ -52,7 +61,8 @@
[style style]) [style style])
(when bitmap? (when bitmap?
(let ([hbitmap (bitmap->hbitmap label #:bg (get-button-background))]) (let ([hbitmap (bitmap->hbitmap (if (pair? label) (car label) label)
#:bg (get-button-background))])
(remember-label-bitmap hbitmap) (remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM)))) (cast hbitmap _HBITMAP _LPARAM))))
@ -64,6 +74,12 @@
(define/public (auto-size-button font label) (define/public (auto-size-button font label)
(cond (cond
[orientation
(let ([h? (memq orientation '(left right))])
(auto-size font (list (car label) (cadr label))
0 0 4 4
#:combine-width (if h? + max)
#:combine-height (if h? max +)))]
[bitmap? [bitmap?
(auto-size font label 0 0 4 4)] (auto-size font label 0 0 4 4)]
[else [else