121 lines
3.9 KiB
Racket
121 lines
3.9 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")
|
|
|
|
(provide
|
|
(protect-out message%))
|
|
|
|
(define STM_SETIMAGE #x0172)
|
|
|
|
(define SS_LEFT #x00000000)
|
|
(define SS_BITMAP #x0000000E)
|
|
(define SS_ICON #x00000003)
|
|
|
|
(define IDI_APPLICATION 32512)
|
|
(define IDI_HAND 32513)
|
|
(define IDI_QUESTION 32514)
|
|
(define IDI_EXCLAMATION 32515)
|
|
(define IDI_WARNING IDI_EXCLAMATION)
|
|
(define IDI_ERROR IDI_HAND)
|
|
|
|
(define IMAGE_ICON 1)
|
|
|
|
(define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON))
|
|
(define-kernel32 GetModuleFileNameW (_wfun _pointer _pointer _DWORD -> _DWORD))
|
|
|
|
(define-shell32 ExtractIconW (_wfun _HINSTANCE _string/utf-16 _UINT -> (r : _HICON)
|
|
-> (or r (failed 'ExtractIconW))))
|
|
|
|
(define ERROR_INSUFFICIENT_BUFFER 122)
|
|
|
|
(define app-icon
|
|
(delay
|
|
(let ()
|
|
(let ([path
|
|
(let loop ([size 1024])
|
|
(let ([p (make-bytes (* (ctype-sizeof _WCHAR) 1024))])
|
|
(let ([r (GetModuleFileNameW #f p size)])
|
|
(cond
|
|
[(and (or (zero? r) (= r size))
|
|
(= (GetLastError) ERROR_INSUFFICIENT_BUFFER))
|
|
(loop (* size 2))]
|
|
[(zero? r) (failed 'GetModuleFileNameW)]
|
|
[else (cast p _gcpointer _string/utf-16)]))))])
|
|
(if path
|
|
(ExtractIconW hInstance path 0)
|
|
(LoadIconW #f IDI_APPLICATION))))))
|
|
(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 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 (force (case label
|
|
[(caution) warning-icon]
|
|
[(stop) error-icon]
|
|
[else app-icon]))
|
|
_HICON _LPARAM)))
|
|
|
|
(set-control-font font)
|
|
|
|
(if (symbol? label)
|
|
(set-size -11111 -11111 32 32)
|
|
(auto-size font label 0 0 0 0))
|
|
|
|
(define/override (get-setimage-message)
|
|
STM_SETIMAGE)))
|