win32 menu and button callbacks
This commit is contained in:
parent
dd9a0772b3
commit
bc0869f43c
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"../common/event.rkt"
|
||||
"item.rkt"
|
||||
"utils.rkt"
|
||||
"const.rkt"
|
||||
|
@ -14,6 +15,8 @@
|
|||
|
||||
(init parent cb label x y w h style font)
|
||||
|
||||
(define callback cb)
|
||||
|
||||
(super-new [parent parent]
|
||||
[hwnd
|
||||
(CreateWindowExW 0
|
||||
|
@ -29,4 +32,11 @@
|
|||
|
||||
(auto-size label 40 12 12 0)
|
||||
|
||||
(define/public (do-command)
|
||||
(queue-window-event this (lambda ()
|
||||
(callback this
|
||||
(new control-event%
|
||||
[event-type 'button]
|
||||
[time-stamp (current-milliseconds)])))))
|
||||
|
||||
(def/public-unimplemented set-border))
|
||||
|
|
|
@ -566,3 +566,26 @@
|
|||
(define GW_HWNDPREV 3)
|
||||
(define GW_OWNER 4)
|
||||
(define GW_CHILD 5)
|
||||
|
||||
(define MF_INSERT #x00000000)
|
||||
(define MF_CHANGE #x00000080)
|
||||
(define MF_APPEND #x00000100)
|
||||
(define MF_DELETE #x00000200)
|
||||
(define MF_REMOVE #x00001000)
|
||||
(define MF_BYCOMMAND #x00000000)
|
||||
(define MF_BYPOSITION #x00000400)
|
||||
(define MF_SEPARATOR #x00000800)
|
||||
(define MF_ENABLED #x00000000)
|
||||
(define MF_GRAYED #x00000001)
|
||||
(define MF_DISABLED #x00000002)
|
||||
(define MF_UNCHECKED #x00000000)
|
||||
(define MF_CHECKED #x00000008)
|
||||
(define MF_USECHECKBITMAPS #x00000200)
|
||||
(define MF_STRING #x00000000)
|
||||
(define MF_BITMAP #x00000004)
|
||||
(define MF_OWNERDRAW #x00000100)
|
||||
(define MF_POPUP #x00000010)
|
||||
(define MF_MENUBARBREAK #x00000020)
|
||||
(define MF_MENUBREAK #x00000040)
|
||||
(define MF_UNHILITE #x00000000)
|
||||
(define MF_HILITE #x00000080)
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
(only-in racket/list last)
|
||||
ffi/unsafe
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
"../common/queue.rkt"
|
||||
"utils.ss"
|
||||
"const.ss"
|
||||
|
@ -88,6 +89,10 @@
|
|||
(when on? (set-frame-focus))
|
||||
(queue-window-event this (lambda () (on-activate on?))))))
|
||||
0]
|
||||
[(and (= msg WM_COMMAND)
|
||||
(zero? (HIWORD wParam)))
|
||||
(queue-window-event this (lambda () (on-menu-command (LOWORD wParam))))
|
||||
0]
|
||||
[else (super wndproc w msg wParam lParam)]))
|
||||
|
||||
(define/public (on-close) (void))
|
||||
|
@ -104,7 +109,9 @@
|
|||
|
||||
(def/public-unimplemented on-toolbar-click)
|
||||
(def/public-unimplemented on-menu-click)
|
||||
(def/public-unimplemented on-menu-command)
|
||||
|
||||
(define/public (on-menu-command i) (void))
|
||||
|
||||
(def/public-unimplemented on-mdi-activate)
|
||||
|
||||
(define/public (enforce-size min-x min-y max-x max-y step-x step-y)
|
||||
|
@ -153,7 +160,11 @@
|
|||
(def/public-unimplemented iconized?)
|
||||
(def/public-unimplemented get-menu-bar)
|
||||
|
||||
(define/public (set-menu-bar mb) (void))
|
||||
(define menu-bar #f)
|
||||
(define/public (set-menu-bar mb)
|
||||
(atomically
|
||||
(set! menu-bar mb)
|
||||
(send mb set-parent this)))
|
||||
|
||||
(def/public-unimplemented set-icon)
|
||||
(def/public-unimplemented iconize)
|
||||
|
|
|
@ -1,13 +1,40 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt")
|
||||
ffi/unsafe
|
||||
"../../lock.rkt"
|
||||
"../../syntax.rkt"
|
||||
"utils.rkt"
|
||||
"types.rkt"
|
||||
"const.rkt")
|
||||
|
||||
(provide menu-bar%)
|
||||
|
||||
(defclass menu-bar% object%
|
||||
(def/public-unimplemented set-label-top)
|
||||
(def/public-unimplemented number)
|
||||
(def/public-unimplemented enable-top)
|
||||
(def/public-unimplemented delete)
|
||||
(define/public (append m l) (void))
|
||||
(super-new))
|
||||
(define-user32 CreateMenu (_wfun -> _HMENU))
|
||||
(define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL)
|
||||
-> (unless r (failed 'SetMenu))))
|
||||
(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL)
|
||||
-> (unless r (failed 'DrawMenuBar))))
|
||||
|
||||
(define menu-bar%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
||||
(define hmenu (CreateMenu))
|
||||
|
||||
(define menus null)
|
||||
|
||||
(def/public-unimplemented set-label-top)
|
||||
(def/public-unimplemented number)
|
||||
(def/public-unimplemented enable-top)
|
||||
(def/public-unimplemented delete)
|
||||
|
||||
(public [append-item append])
|
||||
(define (append-item m lbl)
|
||||
(let ([l (append menus (list m))])
|
||||
(atomically
|
||||
(set! menus l)
|
||||
(send m set-parent this lbl hmenu))))
|
||||
|
||||
(define/public (set-parent f)
|
||||
(SetMenu (send f get-hwnd) hmenu)
|
||||
(DrawMenuBar (send f get-hwnd)))))
|
||||
|
|
|
@ -1,9 +1,43 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(require ffi/unsafe
|
||||
scheme/class
|
||||
"../../syntax.rkt")
|
||||
|
||||
(provide menu-item%)
|
||||
(provide menu-item%
|
||||
id-to-menu-item)
|
||||
|
||||
;; Menu itens are identified by 16-bit numbers, so we have
|
||||
;; to keep a hash mapping them to menu items.
|
||||
(define ids (make-hash))
|
||||
|
||||
(define (id-to-menu-item id)
|
||||
(let ([wb (hash-ref ids id #f)])
|
||||
(and wb (weak-box-value wb))))
|
||||
|
||||
(defclass menu-item% object%
|
||||
(define/public (id) this)
|
||||
|
||||
(define id
|
||||
(let loop ()
|
||||
(let ([id (add1 (random #x7FFE))])
|
||||
(let ([wb (hash-ref ids id #f)])
|
||||
(if (and wb
|
||||
(weak-box-value wb))
|
||||
(loop)
|
||||
(begin
|
||||
(hash-set! ids id (make-weak-box this))
|
||||
id))))))
|
||||
|
||||
(define parent #f)
|
||||
(define label #f)
|
||||
(define checkable? #f)
|
||||
|
||||
(define/public (set-parent p lbl chkbl?)
|
||||
(set! parent p)
|
||||
(set! label lbl)
|
||||
(set! checkable? chkbl?)
|
||||
id)
|
||||
|
||||
(public [get-id id])
|
||||
(define (get-id) id)
|
||||
|
||||
(super-new))
|
||||
|
|
|
@ -1,14 +1,38 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt")
|
||||
ffi/unsafe
|
||||
"../../lock.rkt"
|
||||
"../../syntax.rkt"
|
||||
"utils.rkt"
|
||||
"types.rkt"
|
||||
"const.rkt"
|
||||
"menu-item.rkt")
|
||||
|
||||
(provide menu%)
|
||||
|
||||
(define-user32 CreatePopupMenu (_wfun -> _HMENU))
|
||||
(define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL)
|
||||
-> (unless r (failed 'AppendMenuW))))
|
||||
|
||||
(defclass menu% object%
|
||||
(init label
|
||||
(init lbl
|
||||
callback
|
||||
font)
|
||||
|
||||
(define label lbl)
|
||||
(define parent #f)
|
||||
(define items null)
|
||||
|
||||
(define hmenu (CreatePopupMenu))
|
||||
|
||||
(define/public (set-parent p lbl parent-hmenu)
|
||||
(set! label lbl)
|
||||
(set! parent p)
|
||||
(AppendMenuW parent-hmenu
|
||||
(bitwise-ior MF_POPUP MF_STRING)
|
||||
hmenu
|
||||
lbl))
|
||||
|
||||
(def/public-unimplemented select)
|
||||
(def/public-unimplemented get-font)
|
||||
(def/public-unimplemented set-width)
|
||||
|
@ -24,9 +48,14 @@
|
|||
|
||||
(public [append-item append])
|
||||
(define (append-item i label help-str-or-submenu chckable?)
|
||||
(void))
|
||||
(let ([id (send (id-to-menu-item i) set-parent this label chckable?)])
|
||||
(atomically
|
||||
(set! items (append items (list i)))
|
||||
(AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label))))
|
||||
|
||||
(define/public (append-separator)
|
||||
(void))
|
||||
(atomically
|
||||
(set! items (append items (list #f)))
|
||||
(AppendMenuW hmenu MF_SEPARATOR #f #f)))
|
||||
|
||||
(super-new))
|
||||
|
|
|
@ -6,6 +6,7 @@
|
|||
"types.rkt"
|
||||
"utils.rkt"
|
||||
"const.rkt"
|
||||
"menu-item.rkt"
|
||||
racket/draw)
|
||||
|
||||
(provide
|
||||
|
@ -84,7 +85,6 @@
|
|||
(define-unimplemented get-display-depth)
|
||||
(define-unimplemented is-color-display?)
|
||||
(define-unimplemented file-selector)
|
||||
(define-unimplemented id-to-menu-item)
|
||||
(define-unimplemented get-the-x-selection)
|
||||
(define-unimplemented get-the-clipboard)
|
||||
(define-unimplemented show-print-setup)
|
||||
|
|
|
@ -10,7 +10,9 @@
|
|||
define-comctl32
|
||||
define-uxtheme
|
||||
define-mz
|
||||
failed)
|
||||
failed
|
||||
|
||||
SendMessageW)
|
||||
|
||||
(define gdi32-lib (ffi-lib "gdi32.dll"))
|
||||
(define user32-lib (ffi-lib "user32.dll"))
|
||||
|
@ -30,3 +32,5 @@
|
|||
(error who "call failed (~s)"
|
||||
(GetLastError)))
|
||||
|
||||
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
||||
|
||||
|
|
|
@ -36,8 +36,6 @@
|
|||
|
||||
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
|
||||
|
||||
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
||||
|
||||
(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL)
|
||||
-> (unless r (failed 'MoveWindow))))
|
||||
|
||||
|
@ -46,6 +44,11 @@
|
|||
(define SW_SHOW 5)
|
||||
(define SW_HIDE 0)
|
||||
|
||||
(define-cstruct _NMHDR
|
||||
([hwndFrom _HWND]
|
||||
[idFrom _pointer]
|
||||
[code _UINT]))
|
||||
|
||||
(define-user32 GetDialogBaseUnits (_fun -> _LONG))
|
||||
(define measure-dc #f)
|
||||
|
||||
|
@ -99,6 +102,20 @@
|
|||
[(= msg WM_CHAR)
|
||||
(do-key wParam lParam #t #f)
|
||||
0]
|
||||
[(= msg WM_COMMAND)
|
||||
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
|
||||
[wx (any-hwnd->wx control-hwnd)])
|
||||
(if wx
|
||||
(begin
|
||||
(send wx do-command)
|
||||
0)
|
||||
(DefWindowProcW w msg wParam lParam)))]
|
||||
[(= msg WM_NOTIFY)
|
||||
(let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
|
||||
[control-hwnd (NMHDR-hwndFrom nmhdr)]
|
||||
[wx (any-hwnd->wx control-hwnd)])
|
||||
(when wx (send wx do-command)))
|
||||
0]
|
||||
[else
|
||||
(DefWindowProcW w msg wParam lParam)]))
|
||||
|
||||
|
|
|
@ -680,17 +680,11 @@
|
|||
(when mb (set! menu-bar mb))
|
||||
(super set-menu-bar mb))]
|
||||
[on-menu-command
|
||||
(entry-point
|
||||
(lambda (id)
|
||||
(let ([wx (wx:id-to-menu-item id)])
|
||||
(let ([go (lambda ()
|
||||
(do-command (wx->mred wx) (make-object wx:control-event% 'menu)))])
|
||||
(if (eq? 'windows (system-type))
|
||||
;; Windows: need trampoline
|
||||
(wx:queue-callback
|
||||
(entry-point (lambda () (go)))
|
||||
wx:middle-queue-key)
|
||||
(go))))))]
|
||||
(entry-point
|
||||
(lambda (id)
|
||||
(let ([wx (wx:id-to-menu-item id)])
|
||||
(when wx
|
||||
(do-command (wx->mred wx) (make-object wx:control-event% 'menu))))))]
|
||||
[on-menu-click
|
||||
(entry-point
|
||||
(lambda ()
|
||||
|
|
Loading…
Reference in New Issue
Block a user