From d554cde30f163d310b87329b2154b7444115c43b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 12 Oct 2010 15:32:41 -0600
Subject: [PATCH] win32: set-label with bitmaps

original commit: 80ce36d30d85ed643dd4c02648ba8e728ad5fd51
---
 collects/mred/private/wx/win32/item.rkt    | 17 ++++++++++++++---
 collects/mred/private/wx/win32/message.rkt |  8 ++++++--
 2 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt
index a74d0cd6..0ebbc88a 100644
--- a/collects/mred/private/wx/win32/item.rkt
+++ b/collects/mred/private/wx/win32/item.rkt
@@ -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)))
 
diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt
index 2572c55b..de6cccdc 100644
--- a/collects/mred/private/wx/win32/message.rkt
+++ b/collects/mred/private/wx/win32/message.rkt
@@ -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)))