97 lines
2.7 KiB
Racket
97 lines
2.7 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/draw
|
|
racket/promise
|
|
ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"../common/event.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"window.rkt"
|
|
"wndclass.rkt"
|
|
"hbitmap.rkt"
|
|
"types.rkt"
|
|
"icons.rkt")
|
|
|
|
(provide
|
|
(protect-out message%))
|
|
|
|
(define STM_SETIMAGE #x0172)
|
|
|
|
(define SS_LEFT #x00000000)
|
|
(define SS_LEFTNOWORDWRAP #x0000000C)
|
|
(define SS_BITMAP #x0000000E)
|
|
(define SS_ICON #x00000003)
|
|
|
|
(define IMAGE_ICON 1)
|
|
|
|
(define warning-icon
|
|
(delay
|
|
(LoadIconW #f IDI_WARNING)))
|
|
(define error-icon
|
|
(delay
|
|
(LoadIconW #f IDI_ERROR)))
|
|
|
|
(define message%
|
|
(class item%
|
|
(inherit auto-size set-size set-control-font get-hwnd
|
|
remember-label-bitmap)
|
|
|
|
(init parent label
|
|
x y
|
|
style font)
|
|
|
|
(define bitmap? (label . is-a? . bitmap%))
|
|
|
|
(define/public (get-class) "PLTSTATIC")
|
|
|
|
(super-new [callback void]
|
|
[parent parent]
|
|
[hwnd
|
|
(CreateWindowExW/control 0
|
|
(get-class)
|
|
(if (string? label)
|
|
label
|
|
"<image>")
|
|
(bitwise-ior (if (string? label)
|
|
SS_LEFTNOWORDWRAP
|
|
SS_LEFT)
|
|
WS_CHILD WS_CLIPSIBLINGS
|
|
(if bitmap?
|
|
SS_BITMAP
|
|
(if (symbol? label)
|
|
SS_ICON
|
|
0)))
|
|
0 0 0 0
|
|
(send parent get-content-hwnd)
|
|
#f
|
|
hInstance
|
|
#f)]
|
|
[style style])
|
|
|
|
(when bitmap?
|
|
(let ([hbitmap (bitmap->hbitmap label)])
|
|
(remember-label-bitmap hbitmap)
|
|
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP
|
|
(cast hbitmap _HBITMAP _LPARAM))))
|
|
|
|
(when (symbol? label)
|
|
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON
|
|
(cast (case label
|
|
[(caution) (force warning-icon)]
|
|
[(stop) (force error-icon)]
|
|
[else app-icon])
|
|
_HICON _LPARAM)))
|
|
|
|
(set-control-font font)
|
|
|
|
(if (symbol? label)
|
|
(set-size #f #f 32 32)
|
|
(auto-size font (strip-& label) 0 0 0 0))
|
|
|
|
(define/public (set-preferred-size) #f)
|
|
|
|
(define/override (get-setimage-message)
|
|
STM_SETIMAGE)))
|