73 lines
2.8 KiB
Racket
73 lines
2.8 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"font.rkt")
|
|
|
|
(provide
|
|
(protect-out get-theme-logfont
|
|
get-theme-font-face
|
|
get-theme-font-size
|
|
OpenThemeData
|
|
CloseThemeData
|
|
DrawThemeParentBackground
|
|
DrawThemeBackground
|
|
DrawThemeEdge
|
|
EnableThemeDialogTexture))
|
|
|
|
(define _HTHEME (_cpointer 'HTHEME))
|
|
|
|
(define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT)
|
|
-> (when (negative? r)
|
|
(error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))
|
|
#:wrap (deallocator))
|
|
(define (maybe-CloseThemeData v) (when v (CloseThemeData v)))
|
|
(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> (_or-null _HTHEME))
|
|
#:wrap (allocator maybe-CloseThemeData))
|
|
|
|
(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONTW))
|
|
-> (r : _HRESULT)
|
|
-> (if (negative? r)
|
|
(error 'GetThemeFont "failed: ~s" (bitwise-and #xFFFF r))
|
|
f)))
|
|
|
|
(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONTW))
|
|
-> (r : _HRESULT)
|
|
-> (if (negative? r)
|
|
(error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r))
|
|
f)))
|
|
|
|
(define-uxtheme DrawThemeBackground (_wfun _HTHEME _HDC _int _int _RECT-pointer (_or-null _RECT-pointer) -> (r : _HRESULT)
|
|
-> (when (negative? r)
|
|
(error 'DrawThemeBackground "failed: ~s" (bitwise-and #xFFFF r)))))
|
|
(define-uxtheme DrawThemeParentBackground (_wfun _HWND _HDC _pointer -> (r : _HRESULT)
|
|
-> (when (negative? r)
|
|
(error 'DrawThemeParentBackground "failed: ~s" (bitwise-and #xFFFF r)))))
|
|
(define-uxtheme DrawThemeEdge (_wfun _HWND _HDC _int _int _RECT-pointer _int _int _RECT-pointer -> (r : _HRESULT)
|
|
-> (when (negative? r)
|
|
(error 'DrawThemeEdge "failed: ~s" (bitwise-and #xFFFF r)))))
|
|
|
|
(define-uxtheme EnableThemeDialogTexture (_wfun _HWND _DWORD -> (r : _HRESULT)
|
|
-> (when (negative? r)
|
|
(error 'EnableThemeDialogTexture "failed: ~s" (bitwise-and #xFFFF r)))))
|
|
|
|
(define BP_PUSHBUTTON 1)
|
|
(define PBS_NORMAL 1)
|
|
(define TMT_FONT 210)
|
|
(define TMT_BODYFONT 809)
|
|
|
|
(define TMT_MSGBOXFONT 805)
|
|
|
|
(define theme-logfont (GetThemeSysFont #f TMT_MSGBOXFONT))
|
|
|
|
(define (get-theme-logfont)
|
|
theme-logfont)
|
|
|
|
(define (get-theme-font-face)
|
|
(cast (array-ptr (LOGFONTW-lfFaceName theme-logfont)) _pointer _string/utf-16))
|
|
|
|
(define (get-theme-font-size)
|
|
(abs (LOGFONTW-lfHeight theme-logfont)))
|