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

win32: control font

Browse Source 
original commit: df94c048236f2e722c8af80364086217812cef44
This commit is contained in:
Matthew Flatt 2010-10-20 15:59:10 -06:00
parent d5cf86d7c0
commit ce0759e490
11 changed files with 76 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/mred/private/wx/win32/button.rkt
View File

@ -64,13 +64,13 @@
(define/public (get-button-background)
#xFFFFFF)
(define/public (auto-size-button label)
(define/public (auto-size-button font label)
(cond
[bitmap?
(auto-size label 0 0 4 4)]
(auto-size font label 0 0 4 4)]
[else
(auto-size label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
(auto-size-button label)
(auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
(auto-size-button font label)
(subclass-control (get-hwnd))

4
collects/mred/private/wx/win32/check-box.rkt
View File

@ -22,8 +22,8 @@
(define/override (get-button-background)
(GetSysColor COLOR_BTNFACE))
(define/override (auto-size-button label)
(auto-size label 0 0 20 0))
(define/override (auto-size-button font label)
(auto-size font label 0 0 20 0))
(define/public (set-value v)
(void (SendMessageW (get-hwnd) BM_SETCHECK (if v 1 0) 0)))

3
collects/mred/private/wx/win32/choice.rkt
View File

@ -58,7 +58,8 @@
(set-control-font font)
;; setting the choice height somehow sets the
;; popup-menu size, not the control that you see
(auto-size (if (null? choices) (list "Choice") choices)
(auto-size font
(if (null? choices) (list "Choice") choices)
0 0 40 0
(lambda (w h)
(set-size -11111 -11111 w (* h 8))))

23
collects/mred/private/wx/win32/font.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang racket
(require racket/class
racket/draw/local
racket/draw/pango)
(provide font->hfont)
(define display-font-map
(pango_win32_font_map_for_display))
(define display-context
(pango_font_map_create_context display-font-map))
(define font-cache (pango_win32_font_cache_new))
(define (font->hfont f)
(let* ([pfont (pango_font_map_load_font display-font-map
display-context
(send f get-pango))]
[logfont (pango_win32_font_logfont pfont)])
(begin0
(pango_win32_font_cache_load font-cache logfont)
(g_free logfont))))

2
collects/mred/private/wx/win32/group-panel.rkt
View File

@ -58,7 +58,7 @@
(define label-h 0)
(set-control-font #f)
(auto-size label 0 0 0 0
(auto-size #f label 0 0 0 0
(lambda (w h)
(set! label-h h)
(set-size -11111 -11111 (+ w 10) (+ h 10))))

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

@ -118,7 +118,7 @@
(if (symbol? label)
(set-size -11111 -11111 32 32)
(auto-size label 0 0 0 0))
(auto-size font label 0 0 0 0))
(define/override (get-setimage-message)
STM_SETIMAGE)))

2
collects/mred/private/wx/win32/procs.rkt
View File

@ -85,7 +85,7 @@
(define run-printout (make-run-printout printer-dc%))
(define (get-double-click-time) 500)
(define (get-control-font-face) "Tahoma")
(define (get-control-font-face) (get-theme-font-face))
(define (get-control-font-size) (get-theme-font-size))
(define (get-control-font-size-in-pixels?) #t)
(define (flush-display) (void))

7
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -80,9 +80,10 @@
(ShowWindow radio-hwnd SW_SHOW)
(set-control-font font radio-hwnd)
(let-values ([(w1 h)
(auto-size label 0 0 20 4 (lambda (w h)
(MoveWindow radio-hwnd 0 (+ y SEP) w h #t)
(values w h)))])
(auto-size font label 0 0 20 4
(lambda (w h)
(MoveWindow radio-hwnd 0 (+ y SEP) w h #t)
(values w h)))])
(cons radio-hwnd
(loop (+ y SEP h) (max w1 w) (cdr labels))))))))

3
collects/mred/private/wx/win32/slider.rkt
View File

@ -112,7 +112,8 @@
(define value-h 0)
(if panel-hwnd
(auto-size (list (format "~s" lo)
(auto-size font
(list (format "~s" lo)
(format "~s" hi))
0 0 0 0 (lambda (w h)
(set! value-w w)

3
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -97,7 +97,8 @@
(define tab-height 0)
(set-control-font #f)
(auto-size (if (null? choices)
(auto-size #f
(if (null? choices)
'("Choice")
choices)
0 0 0 0 #:combine-width +

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

@ -16,7 +16,8 @@
"queue.rkt"
"theme.rkt"
"cursor.rkt"
"key.rkt")
"key.rkt"
"font.rkt")
(provide window%
queue-window-event
@ -306,41 +307,45 @@
(define/public (set-control-font font [hwnd hwnd])
(unless theme-hfont
(set! theme-hfont (CreateFontIndirectW (get-theme-logfont))))
(SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0))
(let ([hfont (if font
(font->hfont font)
theme-hfont)])
(SendMessageW hwnd WM_SETFONT (cast hfont _HFONT _LPARAM) 0)))
(define/public (auto-size label min-w min-h dw dh
(define/public (auto-size font label min-w min-h dw dh
[resize
(lambda (w h) (set-size -11111 -11111 w h))]
#:combine-width [combine-w max]
#:combine-height [combine-h max]
#:scale-w [scale-w 1]
#:scale-h [scale-h 1])
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
[dc (make-object bitmap-dc% bm)]
[font (make-object font% 8 'system)])
(send dc set-font font)
(set! measure-dc dc)))
(let-values ([(w h d a) (let loop ([label label])
(cond
[(null? label) (values 0 0 0 0)]
[(label . is-a? . bitmap%)
(values (send label get-width)
(send label get-height)
0
0)]
[(pair? label)
(let-values ([(w1 h1 d1 a1)
(loop (car label))]
[(w2 h2 d2 a2)
(loop (cdr label))])
(values (combine-w w1 w2) (combine-h h1 h2)
(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)))])
(resize (->int (* scale-h (max (+ w dw) min-w)))
(->int (* scale-w (max (+ h dh) min-h))))))
(atomically
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
[dc (make-object bitmap-dc% bm)])
(set! measure-dc dc)))
(send measure-dc set-font (or font
(make-object font% 8 'system)))
(let-values ([(w h d a) (let loop ([label label])
(cond
[(null? label) (values 0 0 0 0)]
[(label . is-a? . bitmap%)
(values (send label get-width)
(send label get-height)
0
0)]
[(pair? label)
(let-values ([(w1 h1 d1 a1)
(loop (car label))]
[(w2 h2 d2 a2)
(loop (cdr label))])
(values (combine-w w1 w2) (combine-h h1 h2)
(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)))])
(resize (->int (* scale-h (max (+ w dw) min-w)))
(->int (* scale-w (max (+ h dh) min-h)))))))
(define/public (popup-menu m x y)
(let ([gx (box x)]