suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: avoid line-wrap in `meesage%' display

Browse Source 
Also, adjust text measuring to ensure that it is as close
as possible to measurements for a control.

original commit: 2d70017091831a1cb041f16323ec489eadc078ac
This commit is contained in:
Matthew Flatt 2011-11-08 06:51:39 -07:00
parent 9641cb5e70
commit fcd3a38c65
2 changed files with 8 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -19,6 +19,7 @@
(define STM_SETIMAGE #x0172)
(define SS_LEFT #x00000000)
(define SS_LEFTNOWORDWRAP #x0000000C)
(define SS_BITMAP #x0000000E)
(define SS_ICON #x00000003)
@ -83,7 +84,10 @@
(if (string? label)
label
"<image>")
(bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS
(bitwise-ior (if (string? label)
SS_LEFTNOWORDWRAP
SS_LEFT)
WS_CHILD WS_CLIPSIBLINGS
(if bitmap?
SS_BITMAP
(if (symbol? label)

5
collects/mred/private/wx/win32/window.rkt
View File

@ -17,6 +17,7 @@
"theme.rkt"
"cursor.rkt"
"key.rkt"
"dc.rkt"
"font.rkt")
(provide
@ -361,7 +362,7 @@
#:scale-h [scale-h 1])
(atomically
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
(let* ([bm (make-object win32-bitmap% 1 1 #f)]
[dc (make-object bitmap-dc% bm)])
(set! measure-dc dc)))
(send measure-dc set-font (or font
@ -383,7 +384,7 @@
(combine-h d1 d1) (combine-h a1 a2)))]
[else
(send measure-dc get-text-extent label #f #t)]))]
[(->int) (lambda (v) (inexact->exact (floor v)))])
[(->int) (lambda (v) (inexact->exact (ceiling v)))])
(resize (->int (* scale-h (max (+ w dw) min-w)))
(->int (* scale-w (max (+ h dh) min-h)))))))