suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32 scrollbar event handling

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-22 07:03:02 -06:00
parent ee30013098
commit dd9a0772b3
3 changed files with 82 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/mred/private/wx/win32/canvas.rkt
View File

@ -6,6 +6,9 @@
"../../lock.rkt"
"../common/canvas-mixin.rkt"
"../common/backing-dc.rkt"
"../common/event.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
@ -34,10 +37,11 @@
(define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int))
(define-user32 GetScrollPos (_wfun _HWND _int -> _int))
(define-user32 SetScrollPos (_wfun _HWND _int _BOOL -> _int))
(define-user32 SetScrollPos (_wfun _HWND _int _int _BOOL -> _int))
(define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer
= (make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
(bitwise-ior SIF_RANGE SIF_POS SIF_PAGE)
(bitwise-ior SIF_RANGE SIF_POS
SIF_PAGE SIF_TRACKPOS)
0 0 0 0 0))
-> (r : _BOOL)
-> (if r i (error 'GetScrollInfo "failed"))))
@ -52,7 +56,8 @@
[gl-config #f])
(inherit get-hwnd
get-client-size)
get-client-size
get-eventspace)
(define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style))
@ -74,7 +79,7 @@
(define hwnd (get-hwnd))
(define/override (wndproc w msg wparam lparam)
(define/override (wndproc w msg wParam lParam)
(cond
[(= msg WM_PAINT)
(let* ([ps (malloc 128)]
@ -85,7 +90,13 @@
(do-backing-flush this dc hdc))
(EndPaint hdc ps))
0]
[else (super wndproc w msg wparam lparam)]))
[(= msg WM_HSCROLL)
(on-scroll-change SB_HORZ (LOWORD wParam))
0]
[(= msg WM_VSCROLL)
(on-scroll-change SB_VERT (LOWORD wParam))
0]
[else (super wndproc w msg wParam lParam)]))
(define dc (new dc% [canvas this]))
(send dc start-backing-retained)
@ -116,7 +127,7 @@
(define/override (refresh) (queue-paint))
(define/public (queue-backing-flush)
(InvalidateRect hwnd #f #t))
(InvalidateRect hwnd #f #f))
(define/public (make-compatible-bitmap w h)
(send dc make-backing-bitmap w h))
@ -170,14 +181,13 @@
(SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)))
(def/public-unimplemented set-background-to-gray)
(def/public-unimplemented on-scroll)
(define/public (get-scroll-pos which)
(GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))
(define/public (get-scroll-range which)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(+ (SCROLLINFO-nMax i)
(SCROLLINFO-nPage i)
(+ (- (SCROLLINFO-nMax i)
(SCROLLINFO-nPage i))
1)))
(define/public (get-scroll-page which)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
@ -193,7 +203,7 @@
h-scroll-visible?)
SIF_DISABLENOSCROLL
0)))
(set-SCROLLINFO-nMax! i (- v (SCROLLINFO-nPage i) -1))
(set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1))
(SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(define/public (set-scroll-page which v)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
@ -203,11 +213,40 @@
h-scroll-visible?)
SIF_DISABLENOSCROLL
0)))
(set-SCROLLINFO-nMax! i (- (+ (SCROLLINFO-nMax i) (SCROLLINFO-nPage i))
v))
(set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i))
v))
(set-SCROLLINFO-nPage! i v)
(SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(define/public (on-scroll e) (void))
(define/private (on-scroll-change dir part)
(let ([i (GetScrollInfo hwnd dir)])
(let ([new-pos
(cond
[(= part SB_TOP) 0]
[(= part SB_BOTTOM) (SCROLLINFO-nMax i)]
[(= part SB_LINEUP) (max 0 (sub1 (SCROLLINFO-nPos i)))]
[(= part SB_LINEDOWN) (min (SCROLLINFO-nMax i) (add1 (SCROLLINFO-nPos i)))]
[(= part SB_PAGEUP) (max 0 (- (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))]
[(= part SB_PAGEDOWN) (min (SCROLLINFO-nMax i) (+ (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))]
[(= part SB_THUMBTRACK) (SCROLLINFO-nTrackPos i)]
[else (SCROLLINFO-nPos i)])])
(unless (= new-pos (SCROLLINFO-nPos i))
(set-SCROLLINFO-nPos! i new-pos)
(set-SCROLLINFO-fMask! i SIF_POS)
(SetScrollInfo 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]))))
(constrained-reply (get-eventspace)
(lambda ()
(let loop () (pre-event-sync #t) (when (yield) (loop))))
(void))))))
(define/override (definitely-wants-event? e)
#t)

16
collects/mred/private/wx/win32/const.rkt
View File

@ -418,6 +418,22 @@
(define SIZE_MAXSHOW 3)
(define SIZE_MAXHIDE 4)
(define SB_LINEUP 0)
(define SB_LINELEFT 0)
(define SB_LINEDOWN 1)
(define SB_LINERIGHT 1)
(define SB_PAGEUP 2)
(define SB_PAGELEFT 2)
(define SB_PAGEDOWN 3)
(define SB_PAGERIGHT 3)
(define SB_THUMBPOSITION 4)
(define SB_THUMBTRACK 5)
(define SB_TOP 6)
(define SB_LEFT 6)
(define SB_BOTTOM 7)
(define SB_RIGHT 7)
(define SB_ENDSCROLL 8)
(define SB_HORZ 0)
(define SB_VERT 1)
(define SB_CTL 2)

18
collects/mred/private/wx/win32/procs.rkt
View File

@ -1,7 +1,11 @@
#lang racket/base
(require racket/class
(require ffi/unsafe
racket/class
"../../syntax.rkt"
"theme.rkt"
"types.rkt"
"utils.rkt"
"const.rkt"
racket/draw)
(provide
@ -86,10 +90,18 @@
(define-unimplemented show-print-setup)
(define-unimplemented can-show-print-setup?)
(define-user32 GetSysColor (_wfun _int -> _DWORD))
(define (GetRValue v) (bitwise-and v #xFF))
(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF))
(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF))
(define (get-highlight-background-color)
(make-object color% 0 0 0))
(let ([c (GetSysColor COLOR_HIGHLIGHT)])
(make-object color% (GetRValue c) (GetGValue c) (GetBValue c))))
(define (get-highlight-text-color)
(make-object color% 255 255 255))
(let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)])
(make-object color% (GetRValue c) (GetGValue c) (GetBValue c))))
(define-unimplemented make-screen-bitmap)