105 lines
3.4 KiB
Racket
105 lines
3.4 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
"utils.ss"
|
|
"const.ss"
|
|
"types.ss")
|
|
|
|
(provide
|
|
(protect-out get-theme-logfont
|
|
get-theme-font-face
|
|
get-theme-font-size
|
|
_LOGFONT-pointer
|
|
OpenThemeData
|
|
CloseThemeData
|
|
DrawThemeParentBackground
|
|
DrawThemeBackground
|
|
DrawThemeEdge
|
|
EnableThemeDialogTexture))
|
|
|
|
(define _HTHEME (_cpointer 'HTHEME))
|
|
|
|
(define-cstruct _FaceName1
|
|
([c1 _uint16]
|
|
[c2 _uint16]
|
|
[c3 _uint16]
|
|
[c4 _uint16]
|
|
[c5 _uint16]
|
|
[c6 _uint16]
|
|
[c7 _uint16]
|
|
[c8 _uint16]))
|
|
|
|
(define-cstruct _FaceName
|
|
([f1 _FaceName1]
|
|
[f2 _FaceName1]
|
|
[f3 _FaceName1]
|
|
[f4 _FaceName1]))
|
|
|
|
(define-cstruct _LOGFONT
|
|
([lfHeight _LONG]
|
|
[lfWidth _LONG]
|
|
[lfEscapement _LONG]
|
|
[lfOrientation _LONG]
|
|
[lfWeight _LONG]
|
|
[lfItalic _BYTE]
|
|
[lfUnderline _BYTE]
|
|
[lfStrikeOut _BYTE]
|
|
[lfCharSet _BYTE]
|
|
[lfOutPrecision _BYTE]
|
|
[lfClipPrecision _BYTE]
|
|
[lfQuality _BYTE]
|
|
[lfPitchAndFamily _BYTE]
|
|
[lfFaceName _FaceName])) ; 32 of them
|
|
|
|
(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 _LOGFONT))
|
|
-> (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 _LOGFONT))
|
|
-> (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 (LOGFONT-lfFaceName theme-logfont) _pointer _string/utf-16))
|
|
|
|
(define (get-theme-font-size)
|
|
(abs (LOGFONT-lfHeight theme-logfont)))
|