win32: fix screen-glyph reporting for label mode

because XP doesn't substitute fonts in control labels

original commit: 6defe0ea09368b38f6015cd27caed599fdcf875f
This commit is contained in:
Matthew Flatt 2011-01-11 19:16:39 -07:00
parent bc097d0606
commit 53db50dc93

View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
racket/draw
racket/draw/private/xp
ffi/unsafe
"../../syntax.rkt"
"../../lock.rkt"
@ -19,10 +20,6 @@
(define BM_SETSTYLE #x00F4)
(define-kernel32 GetVersion (_wfun -> _DWORD))
(define xp? (= 5 (bitwise-and #xFF (GetVersion))))
(define base-button%
(class item%
(inherit set-control-font auto-size get-hwnd
@ -136,6 +133,8 @@
(auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
(auto-size-button font label)
;; XP doesn't show both bitmap and string labels,
;; so we synthesize a bitmap label when we have both
(define xp-label-bitmap (and xp? orientation (car label)))
(define xp-label-string (and xp? orientation (string->immutable-string (cadr label))))
(define xp-label-font (and xp? orientation font))