8bb2543b34
(I think the use of bitmaps is the right one here, but this code doesn't actually work, pending PR 11566)
75 lines
2.6 KiB
Racket
75 lines
2.6 KiB
Racket
#lang racket/base
|
|
(require racket/gui/base
|
|
racket/class
|
|
racket/contract)
|
|
|
|
(provide/contract
|
|
[make-bitmap-label (->* (string?
|
|
(or/c path-string?
|
|
(is-a?/c bitmap%)))
|
|
((is-a?/c font%))
|
|
(is-a?/c bitmap%))]
|
|
[bitmap-label-maker (-> string?
|
|
(or/c path-string? (is-a?/c bitmap%))
|
|
(-> any/c (is-a?/c bitmap%)))])
|
|
|
|
(define (make-bitmap-label text filename-or-bitmap [font normal-control-font])
|
|
(define outside-margin 2)
|
|
(define-values (img-bitmap img-width img-height)
|
|
(let ([q (if (filename-or-bitmap . is-a? . bitmap%)
|
|
filename-or-bitmap
|
|
(make-object bitmap% filename-or-bitmap 'unknown/mask))])
|
|
(if (send q ok?)
|
|
(values q
|
|
(send q get-width)
|
|
(send q get-height))
|
|
(let* ([b (make-object bitmap% 1 1)]
|
|
[bdc (make-object bitmap-dc% b)])
|
|
(send bdc clear)
|
|
(send bdc set-bitmap #f)
|
|
(values b 0 0)))))
|
|
(define-values (width height _1 _2)
|
|
(let ([tmp-bitmap-dc (make-object bitmap-dc% (make-bitmap 1 1))])
|
|
(send tmp-bitmap-dc get-text-extent text font)))
|
|
(define middle-margin (if (and (zero? img-width)
|
|
(zero? img-height))
|
|
0
|
|
3))
|
|
(define new-width (inexact->exact
|
|
(floor
|
|
(+ outside-margin
|
|
img-width
|
|
middle-margin
|
|
width
|
|
outside-margin))))
|
|
(define new-height (inexact->exact
|
|
(floor (+ outside-margin
|
|
(max img-height height)
|
|
outside-margin))))
|
|
|
|
(define new-bitmap (make-screen-bitmap new-width new-height))
|
|
(define bitmap-dc (make-object bitmap-dc% new-bitmap))
|
|
(send bitmap-dc clear)
|
|
|
|
(send bitmap-dc draw-bitmap
|
|
img-bitmap
|
|
outside-margin
|
|
(- (/ new-height 2) (/ img-height 2))
|
|
'solid
|
|
(send the-color-database find-color "black")
|
|
(send img-bitmap get-loaded-mask))
|
|
|
|
(send bitmap-dc set-font font)
|
|
(send bitmap-dc draw-text text
|
|
(+ outside-margin img-width middle-margin)
|
|
(- (/ new-height 2) (/ height 2)))
|
|
|
|
(send bitmap-dc set-bitmap #f)
|
|
|
|
new-bitmap)
|
|
|
|
(define (bitmap-label-maker text filename-or-bitmap)
|
|
(let ([bm (make-bitmap-label text filename-or-bitmap)])
|
|
(lambda (area-container-window)
|
|
bm)))
|