161 lines
4.8 KiB
Racket
161 lines
4.8 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
"../../lock.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"icons.rkt")
|
|
|
|
(provide hInstance
|
|
DefWindowProcW
|
|
hwnd->wx
|
|
any-hwnd->wx
|
|
set-hwnd-wx!
|
|
MessageBoxW
|
|
_WndProc)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define all-cells (make-hash))
|
|
|
|
(define (hwnd->wx hwnd)
|
|
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
|
|
(and p (ptr-ref p _racket))))
|
|
|
|
(define (set-hwnd-wx! hwnd wx)
|
|
(let ([c (malloc-immobile-cell wx)])
|
|
(SetWindowLongW hwnd GWLP_USERDATA c)
|
|
(atomically (hash-set! all-cells (cast c _pointer _long) #t))))
|
|
|
|
(define (any-hwnd->wx hwnd)
|
|
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
|
|
(and p
|
|
(atomically (hash-ref all-cells (cast p _pointer _long) #f))
|
|
(let ([wx (ptr-ref p _racket)])
|
|
(and wx
|
|
(send wx is-hwnd? hwnd)
|
|
wx)))))
|
|
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-cstruct _INITCOMMONCONTROLSEX
|
|
([dwSize _DWORD]
|
|
[dwICC _DWORD]))
|
|
|
|
(define-comctl32 InitCommonControlsEx (_wfun _INITCOMMONCONTROLSEX-pointer -> _BOOL))
|
|
|
|
(void
|
|
(InitCommonControlsEx (make-INITCOMMONCONTROLSEX
|
|
(ctype-sizeof _INITCOMMONCONTROLSEX)
|
|
0)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define _WndProc (_wfun #:atomic? #t #:keep (box null)
|
|
_HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
|
|
|
(define-cstruct _WNDCLASS ([style _UINT]
|
|
[lpfnWndProc _WndProc]
|
|
[cbClsExtra _int]
|
|
[cbWndExtra _int]
|
|
[hInstace _HINSTANCE]
|
|
[hIcon _HICON]
|
|
[hCursor _HCURSOR]
|
|
[hbrBackground _HBRUSH]
|
|
[lpszMenuName _permanent-string/utf-16]
|
|
[lpszClassName _permanent-string/utf-16]))
|
|
|
|
(define-user32 RegisterClassW (_wfun _WNDCLASS-pointer -> _ATOM))
|
|
(define-kernel32 GetModuleHandleW (_wfun _pointer -> _HINSTANCE))
|
|
(define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR))
|
|
(define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON))
|
|
|
|
(define-user32 GetClassInfoW (_wfun _HINSTANCE _string/utf-16 (i : (_ptr o _WNDCLASS)) -> (r : _BOOL)
|
|
-> (if r i (failed 'GetClassInfoW))))
|
|
|
|
(define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
|
|
|
#;(define-user32 PostQuitMessage (_wfun _int -> _void))
|
|
|
|
(define (wind-proc w msg wparam lparam)
|
|
(let ([wx (hwnd->wx w)])
|
|
(if wx
|
|
(send wx wndproc w msg wparam lparam DefWindowProcW)
|
|
(DefWindowProcW w msg wparam lparam))))
|
|
|
|
(define hInstance (GetModuleHandleW #f))
|
|
|
|
(void (RegisterClassW (make-WNDCLASS CS_OWNDC
|
|
wind-proc
|
|
0
|
|
0
|
|
hInstance
|
|
(LoadIconW #f IDI_APPLICATION)
|
|
#f
|
|
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
|
|
(cpointer-push-tag! p 'HBRUSH)
|
|
p)
|
|
#f ; menu
|
|
"PLTFrame")))
|
|
|
|
(void (RegisterClassW (make-WNDCLASS CS_OWNDC
|
|
wind-proc
|
|
0
|
|
0
|
|
hInstance
|
|
#f
|
|
#f
|
|
(let ([p (ptr-add #f (+ COLOR_WINDOW 1))])
|
|
(cpointer-push-tag! p 'HBRUSH)
|
|
p)
|
|
#f ; menu
|
|
"PLTCanvas")))
|
|
|
|
(void (RegisterClassW (make-WNDCLASS 0
|
|
wind-proc
|
|
0
|
|
0
|
|
hInstance
|
|
#f
|
|
#f
|
|
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
|
|
(cpointer-push-tag! p 'HBRUSH)
|
|
p)
|
|
#f ; menu
|
|
"PLTPanel")))
|
|
|
|
(define controls-are-transparent? #f)
|
|
|
|
(void (RegisterClassW (make-WNDCLASS 0
|
|
wind-proc
|
|
0
|
|
0
|
|
hInstance
|
|
#f
|
|
#f
|
|
(if controls-are-transparent?
|
|
#f ; transparent
|
|
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
|
|
(cpointer-push-tag! p 'HBRUSH)
|
|
p))
|
|
#f ; menu
|
|
"PLTTabPanel")))
|
|
|
|
(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int))
|
|
|
|
(define (register-no-cursor orig-name)
|
|
(let ([i (GetClassInfoW hInstance orig-name)])
|
|
(set-WNDCLASS-lpszClassName! i (string-append "PLT" orig-name))
|
|
(set-WNDCLASS-hCursor! i #f)
|
|
(void (RegisterClassW i))))
|
|
|
|
(register-no-cursor "BUTTON")
|
|
(register-no-cursor "STATIC")
|
|
(register-no-cursor "LISTBOX")
|
|
(register-no-cursor "COMBOBOX")
|
|
(register-no-cursor "msctls_trackbar32")
|
|
(register-no-cursor "msctls_progress32")
|
|
(register-no-cursor "SysTabControl32")
|