[graphic-forms-cvs] r183 - trunk/src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Fri Jul  7 15:16:26 2006
New Revision: 183

Modified:
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
refactored ctlcolor message handling, implemented better means for setting control fonts

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Fri Jul  7 15:16:26 2006
@@ -117,7 +117,13 @@
 
 (defmethod (setf gfg:font) (font (self control))
   (setf (font-of self) font)
+  (gfs::send-message (gfs:handle self)
+                     gfs::+wm-setfont+
+                     (cffi:pointer-address (gfs:handle font))
+                     1))
+#|
   (redraw self))
+|#
 
 (defmethod gfg:foreground-color :before ((self control))
   (if (gfs:disposed-p self)

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Fri Jul  7 15:16:26 2006
@@ -126,6 +126,21 @@
       (#.gfs::+en-setfocus+  (event-focus-gain disp widget time))
       (#.gfs::+en-update+    (event-modify     disp widget time)))))
 
+(defun process-ctlcolor-message (wparam lparam)
+  (let* ((tc (thread-context))
+         (widget (get-widget tc (cffi:make-pointer lparam)))
+         (hdc (cffi:make-pointer wparam))
+         (bkgdcolor (brush-color-of widget))
+         (textcolor (text-color-of widget))
+         (ret-val 0))
+    (when widget
+      (if bkgdcolor
+        (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor)))
+      (if textcolor
+        (gfs::set-text-color hdc (gfg:color->rgb textcolor)))
+      (setf ret-val (cffi:pointer-address (brush-handle-of widget))))
+    ret-val))
+
 ;;;
 ;;; process-message methods
 ;;;
@@ -309,33 +324,21 @@
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam)
+  (declare (ignore hwnd))
+  (process-ctlcolor-message wparam lparam))
+
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam)
+  (declare (ignore hwnd))
+  (process-ctlcolor-message wparam lparam))
+
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam)
+  (declare (ignore hwnd))
+  (process-ctlcolor-message wparam lparam))
+
 (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam)
   (declare (ignore hwnd))
-  (let* ((tc (thread-context))
-         (widget (get-widget tc (cffi:make-pointer lparam)))
-         (hdc (cffi:make-pointer wparam))
-         (bkgdcolor (brush-color-of widget))
-         (textcolor (text-color-of widget))
-         (ret-val 0))
-    (when widget
-#|
-      ;; temporarily disabling this until I decide whether this sort
-      ;; of sanity check really makes sense (for one thing, I didn't
-      ;; expect buttons with BS_CHECKBOX or BS_RADIOBUTTON to send
-      ;; WM_CTLCOLORSTATIC, but I guess it makes sense).
-      ;;
-      (if (not (or (typep widget 'button) (typep widget 'label)))
-        (warn 'gfs:toolkit-warning :detail "incorrect widget type received WM_CTLCOLORSTATIC"))
-|#
-      (let ((font (font-of widget)))
-        (if font
-          (gfs::select-object hdc (gfs:handle font))))
-      (if bkgdcolor
-        (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor)))
-      (if textcolor
-        (gfs::set-text-color hdc (gfg:color->rgb textcolor)))
-      (setf ret-val (cffi:pointer-address (brush-handle-of widget))))
-    ret-val))
+  (process-ctlcolor-message wparam lparam))
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam)
   (declare (ignore wparam))