win32: canvas autoscroll
This commit is contained in:
Matthew Flatt
parent
682355def4
commit
b459fcf91c
|
|
@ -193,7 +193,6 @@
|
|||
set-auto-size
|
||||
adjust-client-delta infer-client-delta
|
||||
is-auto-scroll? get-virtual-width get-virtual-height
|
||||
reset-auto-scroll
|
||||
refresh-for-autoscroll)
|
||||
|
||||
(define is-combo? (memq 'combo style))
|
||||
|
|
|
|||
|
|
@ -37,6 +37,9 @@
|
|||
(define ETS_NORMAL 1)
|
||||
(define ETS_DISABLE 4)
|
||||
|
||||
(define HTHSCROLL 6)
|
||||
(define HTVSCROLL 7)
|
||||
|
||||
(define-cstruct _SCROLLINFO
|
||||
([cbSize _UINT]
|
||||
[fMask _UINT]
|
||||
|
|
@ -61,7 +64,7 @@
|
|||
|
||||
(define canvas%
|
||||
(canvas-mixin
|
||||
(class (item-mixin window%)
|
||||
(class (canvas-autoscroll-mixin (item-mixin window%))
|
||||
(init parent
|
||||
x y w h
|
||||
style
|
||||
|
|
@ -72,7 +75,10 @@
|
|||
get-client-size
|
||||
get-eventspace
|
||||
set-control-font
|
||||
subclass-control)
|
||||
subclass-control
|
||||
is-auto-scroll? get-virtual-width get-virtual-height
|
||||
reset-auto-scroll
|
||||
refresh-for-autoscroll)
|
||||
|
||||
(define hscroll? (memq 'hscroll style))
|
||||
(define vscroll? (memq 'vscroll style))
|
||||
|
|
@ -182,7 +188,17 @@
|
|||
(define/public (get-dc) dc)
|
||||
|
||||
(define/override (on-resized)
|
||||
(send dc reset-backing-retained))
|
||||
(reset-dc))
|
||||
|
||||
(define/private (reset-dc)
|
||||
(send dc reset-backing-retained)
|
||||
(send dc set-auto-scroll
|
||||
(if (get-virtual-width)
|
||||
(get-virtual-h-pos)
|
||||
0)
|
||||
(if (get-virtual-height)
|
||||
(get-virtual-v-pos)
|
||||
0)))
|
||||
|
||||
(define/override (get-client-hwnd)
|
||||
canvas-hwnd)
|
||||
|
|
@ -232,9 +248,6 @@
|
|||
(unless (zero? paint-suspended)
|
||||
(set! paint-suspended (sub1 paint-suspended)))))
|
||||
|
||||
(define/public (get-virtual-size w h)
|
||||
(get-client-size w h))
|
||||
|
||||
(define transparent? (memq 'transparent style))
|
||||
(define bg-col (make-object color% "white"))
|
||||
(define/public (get-canvas-background) (if transparent?
|
||||
|
|
@ -254,11 +267,10 @@
|
|||
(set! v-scroll-visible? (and v? #t))
|
||||
(ShowScrollBar canvas-hwnd SB_VERT v?))))
|
||||
|
||||
(define/public (set-scrollbars h-step v-step
|
||||
h-len v-len
|
||||
h-page v-page
|
||||
h-pos v-pos
|
||||
auto?)
|
||||
(define/override (do-set-scrollbars h-step v-step
|
||||
h-len v-len
|
||||
h-page v-page
|
||||
h-pos v-pos)
|
||||
(define (make-info len page pos vis?)
|
||||
(make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
|
||||
(bitwise-ior (if vis? SIF_DISABLENOSCROLL 0)
|
||||
|
|
@ -271,6 +283,15 @@
|
|||
(when vscroll?
|
||||
(SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)))
|
||||
|
||||
(define/override (reset-dc-for-autoscroll)
|
||||
(reset-dc)
|
||||
(refresh))
|
||||
|
||||
(define/override (get-virtual-h-pos)
|
||||
(GetScrollPos canvas-hwnd SB_HORZ))
|
||||
(define/override (get-virtual-v-pos)
|
||||
(GetScrollPos canvas-hwnd SB_VERT))
|
||||
|
||||
(def/public-unimplemented set-background-to-gray)
|
||||
|
||||
(define/public (get-scroll-pos which)
|
||||
|
|
@ -326,21 +347,41 @@
|
|||
(set-SCROLLINFO-nPos! i new-pos)
|
||||
(set-SCROLLINFO-fMask! i SIF_POS)
|
||||
(SetScrollInfo canvas-hwnd dir i #t)
|
||||
(queue-window-event
|
||||
this
|
||||
(lambda ()
|
||||
(on-scroll (new scroll-event%
|
||||
[event-type 'thumb]
|
||||
[direction (if (= dir SB_HORZ) 'horizontal 'vertical)]
|
||||
[position new-pos]))))
|
||||
(if (is-auto-scroll?)
|
||||
(refresh-for-autoscroll)
|
||||
(queue-window-event
|
||||
this
|
||||
(lambda ()
|
||||
(on-scroll (new scroll-event%
|
||||
[event-type 'thumb]
|
||||
[direction (if (= dir SB_HORZ) 'horizontal 'vertical)]
|
||||
[position new-pos])))))
|
||||
(constrained-reply (get-eventspace)
|
||||
(lambda ()
|
||||
(let loop () (pre-event-sync #t) (when (yield) (loop))))
|
||||
(void))))))
|
||||
|
||||
(define/override (definitely-wants-event? w e)
|
||||
(or (e . is-a? . key-event%)
|
||||
(ptr-equal? w canvas-hwnd)))
|
||||
(define/override (definitely-wants-event? w msg wParam e)
|
||||
(cond
|
||||
[(e . is-a? . key-event%)
|
||||
;; All key events to canvas, event for combo:
|
||||
#t]
|
||||
[(and (or (= wParam HTVSCROLL)
|
||||
(= wParam HTHSCROLL))
|
||||
(or (= msg WM_NCLBUTTONDOWN)
|
||||
(= msg WM_NCRBUTTONDOWN)
|
||||
(= msg WM_NCMBUTTONDOWN)
|
||||
(= msg WM_NCLBUTTONDBLCLK)
|
||||
(= msg WM_NCRBUTTONDBLCLK)
|
||||
(= msg WM_NCMBUTTONDBLCLK)
|
||||
(= msg WM_NCLBUTTONUP)
|
||||
(= msg WM_NCRBUTTONUP)
|
||||
(= msg WM_NCMBUTTONUP)))
|
||||
;; let scrollbar handle event:
|
||||
#f]
|
||||
[else
|
||||
;; otherwise, just handle events to canvas:
|
||||
(ptr-equal? w canvas-hwnd)]))
|
||||
|
||||
(define/public (on-combo-select i) (void))
|
||||
(define/public (set-combo-text s) (void))
|
||||
|
|
@ -359,9 +400,14 @@
|
|||
(ptr-equal? canvas-hwnd a-hwnd)
|
||||
(ptr-equal? combo-hwnd a-hwnd)))
|
||||
|
||||
(def/public-unimplemented scroll)
|
||||
(define/public (scroll x y)
|
||||
(when (x . > . 0)
|
||||
(set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal)))))
|
||||
(when (y . > . 0)
|
||||
(set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical)))))
|
||||
(when (is-auto-scroll?) (refresh-for-autoscroll)))
|
||||
|
||||
(def/public-unimplemented warp-pointer)
|
||||
(def/public-unimplemented view-start)
|
||||
|
||||
(define/public (set-resize-corner on?)
|
||||
(void)))))
|
||||
|
|
|
|||
|
|
@ -129,21 +129,21 @@
|
|||
(unhide-cursor)
|
||||
(begin0
|
||||
(default w msg wParam lParam)
|
||||
(do-key w wParam lParam #f #f))]
|
||||
(do-key w msg wParam lParam #f #f))]
|
||||
[(= msg WM_KEYDOWN)
|
||||
(do-key w wParam lParam #f #f)
|
||||
(do-key w msg wParam lParam #f #f)
|
||||
0]
|
||||
[(= msg WM_KEYUP)
|
||||
(do-key w wParam lParam #f #t)
|
||||
(do-key w msg wParam lParam #f #t)
|
||||
0]
|
||||
[(and (= msg WM_SYSCHAR)
|
||||
(= wParam VK_MENU))
|
||||
(unhide-cursor)
|
||||
(begin0
|
||||
(default w msg wParam lParam)
|
||||
(do-key w wParam lParam #t #f))]
|
||||
(do-key w msg wParam lParam #t #f))]
|
||||
[(= msg WM_CHAR)
|
||||
(do-key w wParam lParam #t #f)
|
||||
(do-key w msg wParam lParam #t #f)
|
||||
0]
|
||||
[(= msg WM_COMMAND)
|
||||
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
|
||||
|
|
@ -391,10 +391,10 @@
|
|||
(define/public (get-top-frame)
|
||||
(send parent get-top-frame))
|
||||
|
||||
(define/private (do-key w wParam lParam is-char? is-up?)
|
||||
(define/private (do-key w msg wParam lParam is-char? is-up?)
|
||||
(let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])
|
||||
(and e
|
||||
(if (definitely-wants-event? w e)
|
||||
(if (definitely-wants-event? w msg wParam e)
|
||||
(begin
|
||||
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
|
||||
#t)
|
||||
|
|
@ -406,52 +406,52 @@
|
|||
(define/public (try-mouse w msg wParam lParam)
|
||||
(cond
|
||||
[(= msg WM_NCRBUTTONDOWN)
|
||||
(do-mouse w #t 'right-down wParam lParam)]
|
||||
(do-mouse w msg #t 'right-down wParam lParam)]
|
||||
[(= msg WM_NCRBUTTONUP)
|
||||
(do-mouse w #t 'right-up wParam lParam)]
|
||||
(do-mouse w msg #t 'right-up wParam lParam)]
|
||||
[(= msg WM_NCRBUTTONDBLCLK)
|
||||
(do-mouse w #t 'right-down wParam lParam)]
|
||||
(do-mouse w msg #t 'right-down wParam lParam)]
|
||||
[(= msg WM_NCMBUTTONDOWN)
|
||||
(do-mouse w #t 'middle-down wParam lParam)]
|
||||
(do-mouse w msg #t 'middle-down wParam lParam)]
|
||||
[(= msg WM_NCMBUTTONUP)
|
||||
(do-mouse w #t 'middle-up wParam lParam)]
|
||||
(do-mouse w msg #t 'middle-up wParam lParam)]
|
||||
[(= msg WM_NCMBUTTONDBLCLK)
|
||||
(do-mouse w #t 'middle-down wParam lParam)]
|
||||
(do-mouse w msg #t 'middle-down wParam lParam)]
|
||||
[(= msg WM_NCLBUTTONDOWN)
|
||||
(do-mouse w #t 'left-down wParam lParam)]
|
||||
(do-mouse w msg #t 'left-down wParam lParam)]
|
||||
[(= msg WM_NCLBUTTONUP)
|
||||
(do-mouse w #t 'left-up wParam lParam)]
|
||||
(do-mouse w msg #t 'left-up wParam lParam)]
|
||||
[(= msg WM_NCLBUTTONDBLCLK)
|
||||
(do-mouse w #t 'left-down wParam lParam)]
|
||||
(do-mouse w msg #t 'left-down wParam lParam)]
|
||||
[(and (= msg WM_NCMOUSEMOVE)
|
||||
(not (= wParam HTVSCROLL))
|
||||
(not (= wParam HTHSCROLL)))
|
||||
(do-mouse w #t 'motion wParam lParam)]
|
||||
(do-mouse w msg #t 'motion wParam lParam)]
|
||||
[(= msg WM_RBUTTONDOWN)
|
||||
(do-mouse w #f 'right-down wParam lParam)]
|
||||
(do-mouse w msg #f 'right-down wParam lParam)]
|
||||
[(= msg WM_RBUTTONUP)
|
||||
(do-mouse w #f 'right-up wParam lParam)]
|
||||
(do-mouse w msg #f 'right-up wParam lParam)]
|
||||
[(= msg WM_RBUTTONDBLCLK)
|
||||
(do-mouse w #f 'right-down wParam lParam)]
|
||||
(do-mouse w msg #f 'right-down wParam lParam)]
|
||||
[(= msg WM_MBUTTONDOWN)
|
||||
(do-mouse w #f 'middle-down wParam lParam)]
|
||||
(do-mouse w msg #f 'middle-down wParam lParam)]
|
||||
[(= msg WM_MBUTTONUP)
|
||||
(do-mouse w #f 'middle-up wParam lParam)]
|
||||
(do-mouse w msg #f 'middle-up wParam lParam)]
|
||||
[(= msg WM_MBUTTONDBLCLK)
|
||||
(do-mouse w #f 'middle-down wParam lParam)]
|
||||
(do-mouse w msg #f 'middle-down wParam lParam)]
|
||||
[(= msg WM_LBUTTONDOWN)
|
||||
(do-mouse w #f 'left-down wParam lParam)]
|
||||
(do-mouse w msg #f 'left-down wParam lParam)]
|
||||
[(= msg WM_LBUTTONUP)
|
||||
(do-mouse w #f 'left-up wParam lParam)]
|
||||
(do-mouse w msg #f 'left-up wParam lParam)]
|
||||
[(= msg WM_LBUTTONDBLCLK)
|
||||
(do-mouse w #f 'left-down wParam lParam)]
|
||||
(do-mouse w msg #f 'left-down wParam lParam)]
|
||||
[(= msg WM_MOUSEMOVE)
|
||||
(do-mouse w #f 'motion wParam lParam)]
|
||||
(do-mouse w msg #f 'motion wParam lParam)]
|
||||
[(= msg WM_MOUSELEAVE)
|
||||
(do-mouse w #f 'leave wParam lParam)]
|
||||
(do-mouse w msg #f 'leave wParam lParam)]
|
||||
[else #f]))
|
||||
|
||||
(define/private (do-mouse control-hwnd nc? type wParam lParam)
|
||||
(define/private (do-mouse control-hwnd msg nc? type wParam lParam)
|
||||
(let ([x (LOWORD lParam)]
|
||||
[y (HIWORD lParam)]
|
||||
[flags (if nc? 0 wParam)]
|
||||
|
|
@ -495,10 +495,10 @@
|
|||
c))))))
|
||||
(when (memq type '(left-down right-down middle-down))
|
||||
(set-focus))
|
||||
(handle-mouse-event control-hwnd (make-e type)))))
|
||||
(handle-mouse-event control-hwnd msg wParam (make-e type)))))
|
||||
|
||||
(define/private (handle-mouse-event w e)
|
||||
(if (definitely-wants-event? w e)
|
||||
(define/private (handle-mouse-event w msg wParam e)
|
||||
(if (definitely-wants-event? w msg wParam e)
|
||||
(begin
|
||||
(queue-window-event this (lambda () (dispatch-on-event/sync e)))
|
||||
#t)
|
||||
|
|
@ -513,7 +513,7 @@
|
|||
(begin
|
||||
(set! mouse-in? #t)
|
||||
(let ([parent-cursor (generate-parent-mouse-ins mk)])
|
||||
(handle-mouse-event #f (mk 'enter))
|
||||
(handle-mouse-event (get-client-hwnd) 0 0 (mk 'enter))
|
||||
(let ([c (or cursor-handle parent-cursor)])
|
||||
(set! effective-cursor-handle c)
|
||||
c)))))
|
||||
|
|
@ -525,14 +525,14 @@
|
|||
(set! mouse-in? #f)
|
||||
(let ([e (mk 'leave)])
|
||||
(if (eq? (current-eventspace) (get-eventspace))
|
||||
(handle-mouse-event #f e)
|
||||
(handle-mouse-event (get-client-hwnd) 0 0 e)
|
||||
(queue-window-event this
|
||||
(lambda () (dispatch-on-event/sync e))))))
|
||||
|
||||
(define/public (send-child-leaves mk)
|
||||
#f)
|
||||
|
||||
(define/public (definitely-wants-event? w e)
|
||||
(define/public (definitely-wants-event? w msg wParam e)
|
||||
#f)
|
||||
|
||||
(define/public (dispatch-on-char/sync e)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user