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))