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

win32: set-label with bitmaps

Browse Source 
original commit: 80ce36d30d85ed643dd4c02648ba8e728ad5fd51
This commit is contained in:
Matthew Flatt 2010-10-12 15:32:41 -06:00
parent 6793ac1655
commit d554cde30f
2 changed files with 20 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,8 +2,9 @@
(require racket/class (require racket/class
racket/draw racket/draw
ffi/unsafe ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"../common/event.rkt" "../../lock.rkt"
"../common/event.rkt"
"utils.rkt" "utils.rkt"
"const.rkt" "const.rkt"
"window.rkt" "window.rkt"
@ -83,7 +84,17 @@
(set! label-hbitmaps (cons hbitmap label-hbitmaps))) (set! label-hbitmaps (cons hbitmap label-hbitmaps)))
(define/public (set-label s) (define/public (set-label s)
(SetWindowTextW (get-hwnd) s)) (if (s . is-a? . bitmap%)
(let ([hbitmap (bitmap->hbitmap s)])
(atomically
(set! label-hbitmaps (list hbitmap))
(SendMessageW (get-hwnd)
(get-setimage-message)
IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(SetWindowTextW (get-hwnd) s)))
(define/public (get-setimage-message) BM_SETIMAGE)
(def/public-unimplemented get-label))) (def/public-unimplemented get-label)))

8
collects/mred/private/wx/win32/message.rkt
View File

@ -105,6 +105,7 @@
(remember-label-bitmap hbitmap) (remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM)))) (cast hbitmap _HBITMAP _LPARAM))))
(when (symbol? label) (when (symbol? label)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON
(cast (force (case label (cast (force (case label
@ -114,7 +115,10 @@
_HICON _LPARAM))) _HICON _LPARAM)))
(set-control-font font) (set-control-font font)
(if (symbol? label) (if (symbol? label)
(set-size -11111 -11111 32 32) (set-size -11111 -11111 32 32)
(auto-size label 0 0 0 0)))) (auto-size label 0 0 0 0))
(define/override (get-setimage-message)
STM_SETIMAGE)))