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
racket/draw
ffi/unsafe
"../../syntax.rkt"
"../common/event.rkt"
"../../syntax.rkt"
"../../lock.rkt"
"../common/event.rkt"
"utils.rkt"
"const.rkt"
"window.rkt"
@ -83,7 +84,17 @@
(set! label-hbitmaps (cons hbitmap label-hbitmaps)))
(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)))

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

@ -105,6 +105,7 @@
(remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(when (symbol? label)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON
(cast (force (case label
@ -114,7 +115,10 @@
_HICON _LPARAM)))
(set-control-font font)
(if (symbol? label)
(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)))