168 lines
5.4 KiB
Racket
168 lines
5.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/draw
|
|
ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"../common/event.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"window.rkt"
|
|
"wndclass.rkt"
|
|
"types.rkt")
|
|
|
|
(provide
|
|
(protect-out slider%))
|
|
|
|
(define TBS_VERT #x0002)
|
|
(define TBS_HORZ #x0000)
|
|
|
|
(define TBM_GETPOS WM_USER)
|
|
(define TBM_GETRANGEMIN (+ WM_USER 1))
|
|
(define TBM_GETRANGEMAX (+ WM_USER 2))
|
|
(define TBM_GETTIC (+ WM_USER 3))
|
|
(define TBM_SETTIC (+ WM_USER 4))
|
|
(define TBM_SETPOS (+ WM_USER 5))
|
|
(define TBM_SETRANGE (+ WM_USER 6))
|
|
(define TBM_SETRANGEMIN (+ WM_USER 7))
|
|
(define TBM_SETRANGEMAX (+ WM_USER 8))
|
|
|
|
(define SS_CENTER #x00000001)
|
|
|
|
(define THICKNESS 24)
|
|
(define MIN_LENGTH 80)
|
|
|
|
(defclass slider% item%
|
|
(init parent cb
|
|
label
|
|
val lo hi
|
|
x y w
|
|
style
|
|
font)
|
|
(inherit set-control-font
|
|
auto-size)
|
|
|
|
(define callback cb)
|
|
(define vertical? (memq 'vertical style))
|
|
|
|
(define panel-hwnd
|
|
(if (memq 'plain style)
|
|
#f
|
|
(CreateWindowExW 0
|
|
"PLTPanel"
|
|
#f
|
|
(bitwise-ior WS_CHILD)
|
|
0 0 0 0
|
|
(send parent get-content-hwnd)
|
|
#f
|
|
hInstance
|
|
#f)))
|
|
|
|
(define slider-hwnd
|
|
(CreateWindowExW/control 0
|
|
"PLTmsctls_trackbar32"
|
|
label
|
|
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
|
|
(if vertical?
|
|
TBS_VERT
|
|
TBS_HORZ)
|
|
(if panel-hwnd
|
|
WS_VISIBLE
|
|
0))
|
|
0 0 0 0
|
|
(or panel-hwnd
|
|
(send parent get-content-hwnd))
|
|
#f
|
|
hInstance
|
|
#f))
|
|
|
|
(define value-hwnd
|
|
(and panel-hwnd
|
|
(CreateWindowExW/control 0
|
|
"STATIC"
|
|
(format "~s" val)
|
|
(bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
|
|
0 0 0 0
|
|
panel-hwnd
|
|
#f
|
|
hInstance
|
|
#f)))
|
|
|
|
(define hwnd (or panel-hwnd slider-hwnd))
|
|
|
|
(super-new [callback cb]
|
|
[parent parent]
|
|
[hwnd hwnd]
|
|
[extra-hwnds
|
|
(if panel-hwnd
|
|
(list slider-hwnd value-hwnd)
|
|
null)]
|
|
[style style])
|
|
|
|
(define/override (is-hwnd? a-hwnd)
|
|
(or (ptr-equal? hwnd a-hwnd)
|
|
(and panel-hwnd
|
|
(or (ptr-equal? slider-hwnd a-hwnd)
|
|
(ptr-equal? value-hwnd a-hwnd)))))
|
|
|
|
(when value-hwnd
|
|
(set-control-font font value-hwnd))
|
|
|
|
(define value-w 0)
|
|
(define value-h 0)
|
|
|
|
(if panel-hwnd
|
|
(auto-size font
|
|
(list (format "~s" lo)
|
|
(format "~s" hi))
|
|
0 0 0 0 (lambda (w h)
|
|
(set! value-w w)
|
|
(set! value-h h)
|
|
(if vertical?
|
|
(set-size #f #f (+ THICKNESS w) (max h MIN_LENGTH))
|
|
(set-size #f #f (max w MIN_LENGTH) (+ THICKNESS h)))))
|
|
(if vertical?
|
|
(set-size #f #f THICKNESS MIN_LENGTH)
|
|
(set-size #f #f MIN_LENGTH THICKNESS)))
|
|
|
|
(SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi))
|
|
(set-value val)
|
|
|
|
(define/override (set-size x y w h)
|
|
(super set-size x y w h)
|
|
(when panel-hwnd
|
|
(unless (or (= w -1) (= h -1))
|
|
(if vertical?
|
|
(let ([dx (quotient (- w THICKNESS value-w) 2)])
|
|
(MoveWindow slider-hwnd (->screen dx) 0
|
|
(->screen THICKNESS) (->screen h) #t)
|
|
(MoveWindow value-hwnd (->screen (+ dx THICKNESS)) (->screen (quotient (- h value-h) 2))
|
|
(->screen value-w) (->screen value-h) #t))
|
|
(let ([dy (quotient (- h THICKNESS value-h) 2)])
|
|
(MoveWindow slider-hwnd 0 (->screen dy)
|
|
(->screen w) (->screen THICKNESS) #t)
|
|
(MoveWindow value-hwnd (->screen (quotient (- w value-w) 2)) (->screen (+ dy THICKNESS))
|
|
(->screen value-w) (->screen value-h) #t))))))
|
|
|
|
(define/override (size->screen v) (->screen* v))
|
|
|
|
(define/override (control-scrolled)
|
|
(when value-hwnd
|
|
(set-text (get-value)))
|
|
(queue-window-event this (lambda ()
|
|
(callback this
|
|
(new control-event%
|
|
[event-type 'slider]
|
|
[time-stamp (current-milliseconds)])))))
|
|
|
|
(define/public (set-value val)
|
|
(SendMessageW slider-hwnd TBM_SETPOS 1 val)
|
|
(when value-hwnd
|
|
(set-text val)))
|
|
|
|
(define/private (set-text val)
|
|
(SetWindowTextW value-hwnd (format "~s" val)))
|
|
|
|
(define/public (get-value)
|
|
(SendMessageW slider-hwnd TBM_GETPOS 0 0)))
|