966 lines
38 KiB
Racket
966 lines
38 KiB
Racket
#lang racket/base
|
|
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/os-async-channel
|
|
ffi/winapi
|
|
racket/class
|
|
racket/draw
|
|
racket/gui/base
|
|
racket/match)
|
|
|
|
(provide mk-tray
|
|
tray-close
|
|
tray-set-icon!
|
|
tray-set-menu!)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Windows constants and native types
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Shell_NotifyIcon constants
|
|
(define NIM_ADD #x00000000)
|
|
(define NIM_MODIFY #x00000001)
|
|
(define NIM_DELETE #x00000002)
|
|
(define NIM_SETVERSION #x00000004)
|
|
|
|
(define NIF_MESSAGE #x00000001)
|
|
(define NIF_ICON #x00000002)
|
|
(define NIF_TIP #x00000004)
|
|
(define NIF_SHOWTIP #x00000080)
|
|
|
|
(define NOTIFYICON_VERSION_4 4)
|
|
|
|
;; Window messages used by the tray integration.
|
|
(define WM_SIZE #x0005)
|
|
(define WM_CONTEXTMENU #x007B)
|
|
(define WM_NCDESTROY #x0082)
|
|
(define WM_USER #x0400)
|
|
(define WM_APP #x8000)
|
|
(define NIN_SELECT (+ WM_USER 0))
|
|
(define NIN_KEYSELECT (+ WM_USER 1))
|
|
|
|
(define SIZE_MINIMIZED 1)
|
|
|
|
(define IMAGE_ICON 1)
|
|
(define LR_LOADFROMFILE #x00000010)
|
|
(define SM_CXSMICON 49)
|
|
(define SM_CYSMICON 50)
|
|
|
|
(define BI_RGB 0)
|
|
(define DIB_RGB_COLORS 0)
|
|
|
|
;; Windows scalar aliases. Pointer-sized values matter on 64-bit Windows.
|
|
(define _HWND _pointer)
|
|
(define _HICON _pointer)
|
|
(define _UINT_PTR _uintptr)
|
|
(define _DWORD_PTR _uintptr)
|
|
(define _WPARAM _uintptr)
|
|
(define _LPARAM _intptr)
|
|
(define _LRESULT _intptr)
|
|
(define _HBITMAP _pointer)
|
|
|
|
(define-cstruct _BITMAPINFOHEADER
|
|
([biSize _uint32]
|
|
[biWidth _int32]
|
|
[biHeight _int32]
|
|
[biPlanes _uint16]
|
|
[biBitCount _uint16]
|
|
[biCompression _uint32]
|
|
[biSizeImage _uint32]
|
|
[biXPelsPerMeter _int32]
|
|
[biYPelsPerMeter _int32]
|
|
[biClrUsed _uint32]
|
|
[biClrImportant _uint32]))
|
|
|
|
(define-cstruct _ICONINFO
|
|
([fIcon _int32]
|
|
[xHotspot _uint32]
|
|
[yHotspot _uint32]
|
|
[hbmMask _HBITMAP]
|
|
[hbmColor _HBITMAP]))
|
|
|
|
;; NOTIFYICONDATAW as defined by shellapi.h. The uTimeout/uVersion union is
|
|
;; represented by one UINT because this package only uses uVersion.
|
|
(define-cstruct _NOTIFYICONDATAW
|
|
([cbSize _uint32]
|
|
[hWnd _HWND]
|
|
[uID _uint32]
|
|
[uFlags _uint32]
|
|
[uCallbackMessage _uint32]
|
|
[hIcon _HICON]
|
|
[szTip (_array _uint16 128)]
|
|
[dwState _uint32]
|
|
[dwStateMask _uint32]
|
|
[szInfo (_array _uint16 256)]
|
|
[uVersion _uint32]
|
|
[szInfoTitle (_array _uint16 64)]
|
|
[dwInfoFlags _uint32]
|
|
[guidItem (_array _uint8 16)]
|
|
[hBalloonIcon _HICON]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Native Windows bindings
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; shell32 owns the notification-area API; user32/gdi32 provide icon
|
|
;; creation and destruction; comctl32 provides safe window subclassing.
|
|
(define shell32 (ffi-lib "shell32.dll"))
|
|
(define user32 (ffi-lib "user32.dll"))
|
|
(define gdi32 (ffi-lib "gdi32.dll"))
|
|
(define comctl32 (ffi-lib "comctl32.dll"))
|
|
|
|
(define-ffi-definer define-shell32 shell32)
|
|
(define-ffi-definer define-user32 user32)
|
|
(define-ffi-definer define-gdi32 gdi32)
|
|
(define-ffi-definer define-comctl32 comctl32)
|
|
|
|
;; Adds, modifies, configures, or removes a notification-area icon.
|
|
(define-shell32 Shell_NotifyIconW
|
|
(_fun #:abi winapi
|
|
_uint32 _NOTIFYICONDATAW-pointer
|
|
-> _int32))
|
|
|
|
;; Loads a native HICON from an ICO file. The returned icon is owned by us.
|
|
(define-user32 LoadImageW
|
|
(_fun #:abi winapi
|
|
_pointer _string/utf-16 _uint32 _int32 _int32 _uint32
|
|
-> _pointer))
|
|
|
|
;; Releases an HICON that was loaded or created by this module.
|
|
(define-user32 DestroyIcon
|
|
(_fun #:abi winapi _HICON -> _int32))
|
|
|
|
;; Creates an HICON by copying the HBITMAP values in ICONINFO.
|
|
(define-user32 CreateIconIndirect
|
|
(_fun #:abi winapi _ICONINFO-pointer -> _HICON))
|
|
|
|
;; Returns the current Windows small-icon dimensions.
|
|
(define-user32 GetSystemMetrics
|
|
(_fun #:abi winapi _int32 -> _int32))
|
|
|
|
;; Creates the 32-bit color bitmap used while converting PNG to HICON.
|
|
(define-gdi32 CreateDIBSection
|
|
(_fun #:abi winapi
|
|
_pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32
|
|
-> _HBITMAP))
|
|
|
|
;; Creates the monochrome mask required by ICONINFO.
|
|
(define-gdi32 CreateBitmap
|
|
(_fun #:abi winapi
|
|
_int32 _int32 _uint32 _uint32 _pointer
|
|
-> _HBITMAP))
|
|
|
|
;; Releases temporary GDI bitmap objects after CreateIconIndirect copies them.
|
|
(define-gdi32 DeleteObject
|
|
(_fun #:abi winapi _pointer -> _int32))
|
|
|
|
;; Native callback signature used by SetWindowSubclass.
|
|
(define _SUBCLASSPROC
|
|
(_fun #:abi winapi
|
|
_HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR
|
|
-> _LRESULT))
|
|
|
|
;; Adds our message hook without replacing Racket GUI's own window procedure.
|
|
(define-comctl32 SetWindowSubclass
|
|
(_fun #:abi winapi
|
|
_HWND _pointer _UINT_PTR _DWORD_PTR
|
|
-> _int32))
|
|
|
|
;; Detaches the hook installed for an open tray object.
|
|
(define-comctl32 RemoveWindowSubclass
|
|
(_fun #:abi winapi
|
|
_HWND _pointer _UINT_PTR
|
|
-> _int32))
|
|
|
|
;; Forwards every message that racket-tray does not consume.
|
|
(define-comctl32 DefSubclassProc
|
|
(_fun #:abi winapi
|
|
_HWND _uint32 _WPARAM _LPARAM
|
|
-> _LRESULT))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Internal state
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; A tray object owns its HICON and native subclass registration. The HWND is
|
|
;; owned by the Racket top-level window and must never be destroyed here.
|
|
(struct tray (frame
|
|
hwnd
|
|
id
|
|
callback-message
|
|
on-click
|
|
hide-on-minimize?
|
|
eventspace
|
|
event-channel
|
|
event-thread
|
|
subclass-proc
|
|
icon
|
|
menu
|
|
closed?)
|
|
#:mutable)
|
|
|
|
(define next-tray-id 1)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Allocate a process-local identifier for a tray icon.
|
|
; pre : next-tray-id contains the next unused positive identifier.
|
|
; post : next-tray-id is advanced by one when allocation succeeds.
|
|
; result : A unique integer in the range 1 through #xffff.
|
|
; internals:
|
|
; The identifier is also used to derive the private WM_APP callback
|
|
; message. Limiting it to 16 bits keeps that message in the range
|
|
; reserved by Windows for application-private messages.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (allocate-tray-id)
|
|
(define id next-tray-id)
|
|
(when (> id #xffff)
|
|
(error 'mk-tray "too many tray icons have been created in this process"))
|
|
(set! next-tray-id (add1 next-tray-id))
|
|
id)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Convert a Win32 BOOL-style result to a Racket boolean.
|
|
; pre : v is an exact integer returned by a Win32 procedure.
|
|
; post : No state is changed.
|
|
; result : #t for every non-zero value, #f for zero.
|
|
; internals:
|
|
; Win32 BOOL values are integers rather than Racket booleans.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (bool-result? v)
|
|
(not (zero? v)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Run thunk synchronously in the handler thread of eventspace.
|
|
; pre : eventspace is a live Racket GUI eventspace and thunk accepts no
|
|
; arguments.
|
|
; post : thunk has completed, or its exception has been re-raised in the
|
|
; calling thread.
|
|
; result : The value returned by thunk.
|
|
; internals:
|
|
; When already in the handler thread, thunk is called directly.
|
|
; Otherwise queue-callback schedules it and a channel transfers its
|
|
; value or exception back to the caller. This keeps HWND operations
|
|
; on the GUI thread that owns the window.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (call-in-eventspace eventspace thunk)
|
|
(define handler-thread (eventspace-handler-thread eventspace))
|
|
(unless handler-thread
|
|
(error 'racket-tray "the frame's eventspace has been shut down"))
|
|
(if (eq? (current-thread) handler-thread)
|
|
(parameterize ([current-eventspace eventspace])
|
|
(thunk))
|
|
(let ([result-channel (make-channel)])
|
|
(parameterize ([current-eventspace eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(with-handlers ([exn?
|
|
(λ (exn)
|
|
(channel-put result-channel (cons 'error exn)))])
|
|
(channel-put result-channel (cons 'ok (thunk)))))))
|
|
(match (channel-get result-channel)
|
|
[(cons 'ok value) value]
|
|
[(cons 'error exn) (raise exn)]))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Allocate and initialize a NOTIFYICONDATAW structure.
|
|
; pre : hwnd is a valid HWND, id and callback-message are valid unsigned
|
|
; integer values, and icon is either an HICON or #f.
|
|
; post : A zero-initialized native structure has been filled with the common
|
|
; tray fields; the caller may add flags and text fields afterwards.
|
|
; result : A pointer to NOTIFYICONDATAW allocated in atomic memory.
|
|
; internals:
|
|
; Atomic memory is used because the structure is passed directly to
|
|
; Win32 without containing Racket-managed pointers.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (make-notify-data hwnd id callback-message icon)
|
|
(define data
|
|
(cast (malloc _NOTIFYICONDATAW 'atomic)
|
|
_pointer
|
|
_NOTIFYICONDATAW-pointer))
|
|
(memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW))
|
|
(set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW))
|
|
(set-NOTIFYICONDATAW-hWnd! data hwnd)
|
|
(set-NOTIFYICONDATAW-uID! data id)
|
|
(set-NOTIFYICONDATAW-uCallbackMessage! data callback-message)
|
|
(set-NOTIFYICONDATAW-hIcon! data icon)
|
|
data)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Copy a Racket string into a fixed-size UTF-16 Win32 array.
|
|
; pre : array has room for capacity UTF-16 code units and capacity is at
|
|
; least one.
|
|
; post : array contains a zero-terminated copy of text, truncated when
|
|
; necessary to leave room for the terminating zero.
|
|
; result : Unspecified; array is modified in place.
|
|
; internals:
|
|
; The destination is cleared first so truncation always leaves a
|
|
; valid zero-terminated Win32 string.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (set-wide-array! array text capacity)
|
|
(define source (cast text _string/utf-16 _pointer))
|
|
(for ([i (in-range capacity)])
|
|
(array-set! array i 0))
|
|
(let loop ([i 0])
|
|
(when (< i (sub1 capacity))
|
|
(let ([code-unit (ptr-ref source _uint16 i)])
|
|
(unless (zero? code-unit)
|
|
(array-set! array i code-unit)
|
|
(loop (add1 i)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Icon loading
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Load an ICO file as a native Windows small icon.
|
|
; pre : icon-file names an existing ICO file readable by Windows.
|
|
; post : On success a new HICON is owned by the caller.
|
|
; result : A non-#f HICON; raises an exception when LoadImageW fails.
|
|
; internals:
|
|
; Windows is asked for the current SM_CXSMICON/SM_CYSMICON size so
|
|
; the shell receives an icon already sized for the notification area.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (load-ico-icon icon-file)
|
|
(define width (GetSystemMetrics SM_CXSMICON))
|
|
(define height (GetSystemMetrics SM_CYSMICON))
|
|
(define icon
|
|
(LoadImageW #f
|
|
(path->string (path->complete-path icon-file))
|
|
IMAGE_ICON
|
|
width
|
|
height
|
|
LR_LOADFROMFILE))
|
|
(unless icon
|
|
(error 'mk-tray "could not load ICO file: ~a" icon-file))
|
|
icon)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Convert a PNG file with alpha transparency to a native HICON.
|
|
; pre : icon-file names a readable PNG image and the Windows GDI functions
|
|
; needed to create bitmaps and icons are available.
|
|
; post : Temporary HBITMAP objects are released before return; on success
|
|
; the returned HICON is owned by the caller.
|
|
; result : A non-#f HICON; raises an exception when decoding or native icon
|
|
; creation fails.
|
|
; internals:
|
|
; Racket decodes and scales the PNG. Premultiplied ARGB pixels are
|
|
; copied into a top-down 32-bit DIB in Windows BGRA byte order.
|
|
; CreateIconIndirect copies the color and mask bitmaps, allowing the
|
|
; temporary GDI objects to be deleted immediately afterwards.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (png->icon icon-file)
|
|
;; Racket's drawing library already decodes PNG and preserves its alpha
|
|
;; channel. Scale it to the same system-small-icon size that is used for
|
|
;; ICO files, then turn the premultiplied pixels into a native HICON.
|
|
(define source-bitmap
|
|
(read-bitmap icon-file 'png/alpha #f #t))
|
|
(unless (send source-bitmap ok?)
|
|
(error 'mk-tray "could not load PNG file: ~a" icon-file))
|
|
|
|
(define width (max 1 (GetSystemMetrics SM_CXSMICON)))
|
|
(define height (max 1 (GetSystemMetrics SM_CYSMICON)))
|
|
(define source-width (send source-bitmap get-width))
|
|
(define source-height (send source-bitmap get-height))
|
|
|
|
;; Keep the aspect ratio and center non-square images in the tray-icon area.
|
|
(define scale
|
|
(min (/ width source-width)
|
|
(/ height source-height)))
|
|
(define draw-width (max 1 (inexact->exact (round (* source-width scale)))))
|
|
(define draw-height (max 1 (inexact->exact (round (* source-height scale)))))
|
|
(define draw-x (quotient (- width draw-width) 2))
|
|
(define draw-y (quotient (- height draw-height) 2))
|
|
|
|
(define bitmap (make-bitmap width height #t))
|
|
(define dc (new bitmap-dc% [bitmap bitmap]))
|
|
(send dc draw-bitmap-section-smooth
|
|
source-bitmap
|
|
draw-x
|
|
draw-y
|
|
draw-width
|
|
draw-height
|
|
0
|
|
0
|
|
source-width
|
|
source-height)
|
|
(send dc set-bitmap #f)
|
|
|
|
(define pixel-count (* width height))
|
|
(define argb (make-bytes (* pixel-count 4)))
|
|
(send bitmap get-argb-pixels 0 0 width height argb #f #t)
|
|
|
|
(define header
|
|
(make-BITMAPINFOHEADER
|
|
(ctype-sizeof _BITMAPINFOHEADER)
|
|
width
|
|
(- height) ; negative means top-down, matching Racket's row order
|
|
1
|
|
32
|
|
BI_RGB
|
|
(* pixel-count 4)
|
|
0
|
|
0
|
|
0
|
|
0))
|
|
(define bits-out (malloc _pointer 'atomic))
|
|
(ptr-set! bits-out _pointer #f)
|
|
(define color-bitmap
|
|
(CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0))
|
|
(unless color-bitmap
|
|
(error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file))
|
|
|
|
(define mask-bitmap #f)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Release temporary GDI bitmaps created during PNG conversion.
|
|
; pre : color-bitmap and mask-bitmap are HBITMAP values or #f.
|
|
; post : Every non-#f bitmap is deleted and its local variable is set to
|
|
; #f, making repeated cleanup safe.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; This local helper is used on both the normal and exceptional
|
|
; CreateIconIndirect paths so temporary GDI objects never leak.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (cleanup-bitmaps!)
|
|
(when mask-bitmap
|
|
(DeleteObject mask-bitmap)
|
|
(set! mask-bitmap #f))
|
|
(when color-bitmap
|
|
(DeleteObject color-bitmap)
|
|
(set! color-bitmap #f)))
|
|
|
|
(with-handlers ([exn?
|
|
(λ (exn)
|
|
(cleanup-bitmaps!)
|
|
(raise exn))])
|
|
(define dib-bits (ptr-ref bits-out _pointer))
|
|
(unless dib-bits
|
|
(error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file))
|
|
|
|
;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A byte order.
|
|
;; get-argb-pixels was requested premultiplied because that is the form
|
|
;; expected by alpha-blended Windows icons.
|
|
(for ([pixel (in-range pixel-count)])
|
|
(define source (* pixel 4))
|
|
(define alpha (bytes-ref argb source))
|
|
(define red (bytes-ref argb (+ source 1)))
|
|
(define green (bytes-ref argb (+ source 2)))
|
|
(define blue (bytes-ref argb (+ source 3)))
|
|
(ptr-set! dib-bits _uint8 source blue)
|
|
(ptr-set! dib-bits _uint8 (+ source 1) green)
|
|
(ptr-set! dib-bits _uint8 (+ source 2) red)
|
|
(ptr-set! dib-bits _uint8 (+ source 3) alpha))
|
|
|
|
;; For modern 32-bit alpha icons the color bitmap carries transparency.
|
|
;; ICONINFO still requires a same-sized monochrome mask for a color icon.
|
|
(define mask-stride (* 2 (quotient (+ width 15) 16)))
|
|
(define mask-size (* mask-stride height))
|
|
(define mask-bits (malloc mask-size 'atomic))
|
|
(memset mask-bits 0 0 mask-size)
|
|
(set! mask-bitmap
|
|
(CreateBitmap width height 1 1 mask-bits))
|
|
(unless mask-bitmap
|
|
(error 'mk-tray "CreateBitmap failed while loading PNG icon: ~a" icon-file))
|
|
|
|
(define icon-info
|
|
(make-ICONINFO 1 0 0 mask-bitmap color-bitmap))
|
|
(define icon (CreateIconIndirect icon-info))
|
|
|
|
;; CreateIconIndirect copies both bitmaps, so the source GDI objects can
|
|
;; be released immediately. The returned HICON remains owned by us.
|
|
(cleanup-bitmaps!)
|
|
(unless icon
|
|
(error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file))
|
|
icon))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Load a supported icon file into a native HICON.
|
|
; pre : icon-file is a path-string naming an .ico or .png file.
|
|
; post : On success the caller owns the returned HICON.
|
|
; result : An HICON loaded by load-ico-icon or created by png->icon.
|
|
; internals:
|
|
; Dispatch is deliberately based only on the filename extension so
|
|
; the public API stays predictable and small.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (load-icon icon-file)
|
|
(define name
|
|
(string-downcase
|
|
(path->string (path->complete-path icon-file))))
|
|
(cond
|
|
[(regexp-match? #rx"[.]ico$" name)
|
|
(load-ico-icon icon-file)]
|
|
[(regexp-match? #rx"[.]png$" name)
|
|
(png->icon icon-file)]
|
|
[else
|
|
(error 'mk-tray
|
|
"expected an .ico or .png icon file; got: ~a"
|
|
icon-file)]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Extract the low 16 bits from a pointer-sized Win32 value.
|
|
; pre : value is an exact integer.
|
|
; post : No state is changed.
|
|
; result : An integer in the range 0 through #xffff.
|
|
; internals:
|
|
; Tray notification codes are packed into the low word of LPARAM.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (low-word value)
|
|
(bitwise-and value #xffff))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Interpret the low 16 bits of value as a signed Windows coordinate.
|
|
; pre : value is an exact integer.
|
|
; post : No state is changed.
|
|
; result : An integer in the signed 16-bit range.
|
|
; internals:
|
|
; WM_CONTEXTMENU packs signed screen coordinates into WORD values;
|
|
; values >= #x8000 therefore represent negative coordinates.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (signed-word value)
|
|
(define n (low-word value))
|
|
(if (>= n #x8000)
|
|
(- n #x10000)
|
|
n))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Extract the signed X coordinate supplied by a tray notification.
|
|
; pre : wparam is the WPARAM received for a NOTIFYICON_VERSION_4 event.
|
|
; post : No state is changed.
|
|
; result : The signed screen X coordinate from the low word of wparam.
|
|
; internals:
|
|
; NOTIFYICON_VERSION_4 packs the anchor coordinates in WPARAM.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (x-from-wparam wparam)
|
|
(signed-word wparam))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Extract the signed Y coordinate supplied by a tray notification.
|
|
; pre : wparam is the WPARAM received for a NOTIFYICON_VERSION_4 event.
|
|
; post : No state is changed.
|
|
; result : The signed screen Y coordinate from the high word of wparam.
|
|
; internals:
|
|
; The high word is shifted down before signed-word interprets it.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (y-from-wparam wparam)
|
|
(signed-word (arithmetic-shift wparam -16)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Event and menu handling
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Normalize a public tray menu specification to popup-menu%.
|
|
; pre : menu-spec is #f, a popup-menu%, or a list containing two-element
|
|
; (label callback) lists and separator markers.
|
|
; post : Newly created menu items hold callbacks that invoke the supplied
|
|
; zero-argument procedures.
|
|
; result : #f, the original popup-menu%, or a newly created popup-menu%.
|
|
; internals:
|
|
; A simple list is converted directly to Racket GUI menu objects so
|
|
; menu callbacks remain ordinary Racket GUI callbacks rather than
|
|
; native Win32 callback code.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (menu-spec->popup-menu menu-spec)
|
|
(cond
|
|
[(not menu-spec) #f]
|
|
[(is-a? menu-spec popup-menu%) menu-spec]
|
|
[(list? menu-spec)
|
|
(let ([popup (new popup-menu%)])
|
|
(for ([entry (in-list menu-spec)])
|
|
(match entry
|
|
[(or #f 'separator)
|
|
(new separator-menu-item% [parent popup])]
|
|
[(list (? string? label) (? procedure? callback))
|
|
(unless (procedure-arity-includes? callback 0)
|
|
(error 'tray-set-menu!
|
|
"menu callback for ~e does not accept zero arguments"
|
|
label))
|
|
(new menu-item%
|
|
[parent popup]
|
|
[label label]
|
|
[callback (λ (_item _event) (callback))])]
|
|
[_
|
|
(error 'tray-set-menu!
|
|
"expected a popup-menu% or a list containing (list label callback), #f, or 'separator; got: ~e"
|
|
entry)]))
|
|
popup)]
|
|
[else
|
|
(error 'tray-set-menu!
|
|
"expected a popup-menu%, menu specification list, or #f; got: ~e"
|
|
menu-spec)]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Queue application work on the eventspace associated with tray t.
|
|
; pre : t is a tray object and thunk accepts no arguments.
|
|
; post : When the eventspace is live, thunk is queued; it is skipped when
|
|
; the tray has been closed before execution.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; Shutdown races are intentionally ignored here because native tray
|
|
; messages can arrive while the GUI is being torn down.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (queue-eventspace-callback t thunk)
|
|
(define eventspace (tray-eventspace t))
|
|
(unless (eventspace-shutdown? eventspace)
|
|
(with-handlers ([exn:fail? (λ (_exn) (void))])
|
|
(parameterize ([current-eventspace eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(unless (tray-closed? t)
|
|
(thunk))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Start the ordinary Racket thread that dispatches native tray events.
|
|
; pre : t is a newly created tray with an event channel and no event thread.
|
|
; post : tray-event-thread contains the new dispatcher thread; the thread
|
|
; exits after receiving the symbol 'close.
|
|
; result : Unspecified; t is modified in place.
|
|
; internals:
|
|
; Native FFI callbacks only write small immutable event values to the
|
|
; OS async channel. This thread receives those values outside atomic
|
|
; FFI callback mode and queues GUI/user work into the frame eventspace.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (start-event-thread! t)
|
|
(define event-thread
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(match (sync (tray-event-channel t))
|
|
['close
|
|
(void)]
|
|
['activate
|
|
(let ([callback (tray-on-click t)])
|
|
(when callback
|
|
(queue-eventspace-callback t callback)))
|
|
(loop)]
|
|
['minimize
|
|
(queue-eventspace-callback
|
|
t
|
|
(λ ()
|
|
;; Hiding instead of iconizing removes the application from the
|
|
;; taskbar while keeping the HWND alive for the tray icon.
|
|
(send (tray-frame t) show #f)))
|
|
(loop)]
|
|
[(vector 'context-menu screen-x screen-y)
|
|
(queue-eventspace-callback
|
|
t
|
|
(λ ()
|
|
(define menu (tray-menu t))
|
|
(when menu
|
|
(let-values ([(x y)
|
|
(send (tray-frame t)
|
|
screen->client
|
|
screen-x
|
|
screen-y)])
|
|
(send (tray-frame t) popup-menu menu x y)))))
|
|
(loop)]
|
|
[_
|
|
(loop)])))))
|
|
(set-tray-event-thread! t event-thread))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Translate a Shell_NotifyIcon callback message to an internal event.
|
|
; pre : t is an open tray and wparam/lparam are the values supplied by the
|
|
; native tray callback message.
|
|
; post : Recognized activation or context-menu events are written to the
|
|
; tray OS async channel; no GUI or user callback is run directly.
|
|
; result : void.
|
|
; internals:
|
|
; Racket CS executes foreign callbacks in atomic mode. Using
|
|
; os-async-channel-put here is safe and postpones ordinary Racket and
|
|
; GUI work until start-event-thread! receives the event.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (handle-native-tray-event t wparam lparam)
|
|
;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or
|
|
;; user code here. An OS async channel is explicitly safe to use from an OS
|
|
;; callback/thread, so forward the event to an ordinary Racket thread.
|
|
(define notification (low-word lparam))
|
|
(cond
|
|
[(or (= notification NIN_SELECT)
|
|
(= notification NIN_KEYSELECT))
|
|
(os-async-channel-put (tray-event-channel t) 'activate)]
|
|
[(= notification WM_CONTEXTMENU)
|
|
(os-async-channel-put
|
|
(tray-event-channel t)
|
|
(vector 'context-menu
|
|
(x-from-wparam wparam)
|
|
(y-from-wparam wparam)))]
|
|
[else
|
|
(void)]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Native window integration
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create the Win32 subclass procedure used by a tray object.
|
|
; pre : t contains the HWND, callback message, event channel and tray state
|
|
; required by the native callback.
|
|
; post : No subclass is installed by this procedure itself.
|
|
; result : A Racket procedure with the SUBCLASSPROC calling convention.
|
|
; internals:
|
|
; The procedure handles only the private tray callback, optional
|
|
; WM_SIZE/SIZE_MINIMIZED handling, and WM_NCDESTROY cleanup. Every
|
|
; other message is passed unchanged to DefSubclassProc so Racket's
|
|
; own window procedure remains in control.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (make-subclass-proc t)
|
|
(λ (hwnd msg wparam lparam _subclass-id _ref-data)
|
|
(cond
|
|
[(= msg (tray-callback-message t))
|
|
(handle-native-tray-event t wparam lparam)
|
|
0]
|
|
[(and (= msg WM_SIZE)
|
|
(= wparam SIZE_MINIMIZED)
|
|
(tray-hide-on-minimize? t))
|
|
;; Forward only a small value from the native callback. GUI work is
|
|
;; performed later on the frame's eventspace.
|
|
(os-async-channel-put (tray-event-channel t) 'minimize)
|
|
(DefSubclassProc hwnd msg wparam lparam)]
|
|
[(= msg WM_NCDESTROY)
|
|
;; The HWND is going away. Remove the notification-area icon while the
|
|
;; handle is still valid. Windows discards the subclass automatically
|
|
;; as part of window destruction.
|
|
(unless (tray-closed? t)
|
|
(let ([data
|
|
(make-notify-data hwnd
|
|
(tray-id t)
|
|
(tray-callback-message t)
|
|
(tray-icon t))])
|
|
(Shell_NotifyIconW NIM_DELETE data)
|
|
(when (tray-icon t)
|
|
(DestroyIcon (tray-icon t))
|
|
(set-tray-icon! t #f))
|
|
(set-tray-closed?! t #t)
|
|
(os-async-channel-put (tray-event-channel t) 'close)))
|
|
(DefSubclassProc hwnd msg wparam lparam)]
|
|
[else
|
|
(DefSubclassProc hwnd msg wparam lparam)])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Register tray t in the Windows notification area.
|
|
; pre : t has a live HWND and installed subclass; icon is a valid HICON and
|
|
; tooltip is a string.
|
|
; post : On success the shell owns a notification-area entry for t and it is
|
|
; configured for NOTIFYICON_VERSION_4 semantics.
|
|
; result : Unspecified; raises an exception when registration or version setup
|
|
; fails.
|
|
; internals:
|
|
; NIM_ADD installs the icon and callback message. NIM_SETVERSION is
|
|
; issued immediately afterwards so keyboard/context-menu events use
|
|
; the current notification protocol. A failed version setup removes
|
|
; the just-added icon again.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (add-notify-icon! t icon tooltip)
|
|
(define data
|
|
(make-notify-data (tray-hwnd t)
|
|
(tray-id t)
|
|
(tray-callback-message t)
|
|
icon))
|
|
(set-NOTIFYICONDATAW-uFlags!
|
|
data
|
|
(bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP))
|
|
(set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128)
|
|
|
|
(unless (bool-result? (Shell_NotifyIconW NIM_ADD data))
|
|
(error 'mk-tray "Shell_NotifyIconW failed to add the tray icon"))
|
|
|
|
(set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4)
|
|
(unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data))
|
|
(Shell_NotifyIconW NIM_DELETE data)
|
|
(error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4")))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Validate that t is a tray object that is still open.
|
|
; pre : who is a symbol naming the calling procedure.
|
|
; post : No state is changed.
|
|
; result : Unspecified when valid; otherwise raises a precise argument/state
|
|
; exception for the calling procedure.
|
|
; internals:
|
|
; Centralizing this check keeps the mutating public procedures small
|
|
; without introducing a wider abstraction layer.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (check-open-tray who t)
|
|
(unless (tray? t)
|
|
(raise-argument-error who "tray?" t))
|
|
(when (tray-closed? t)
|
|
(error who "tray icon is already closed")))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a Windows notification-area icon bound to a Racket window.
|
|
; pre : frame implements top-level-window<%>, has a native HWND, icon-file
|
|
; names a supported icon, on-click-cb is #f or a zero-argument
|
|
; procedure, and hide-on-minimize? is boolean.
|
|
; post : A native icon is registered, the frame HWND is subclassed, and an
|
|
; event-dispatch thread is running. On failure, resources created up
|
|
; to that point are released.
|
|
; result : A mutable tray object used by tray-close, tray-set-icon! and
|
|
; tray-set-menu!.
|
|
; internals:
|
|
; Creation is performed in the frame's eventspace because the HWND
|
|
; belongs to that GUI thread. The existing Racket HWND is reused;
|
|
; SetWindowSubclass observes tray/minimize messages without replacing
|
|
; Racket's own WndProc.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (mk-tray frame
|
|
icon-file
|
|
on-click-cb
|
|
#:hide-on-minimize? [hide-on-minimize? #f])
|
|
(unless (is-a? frame top-level-window<%>)
|
|
(raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame))
|
|
(unless (boolean? hide-on-minimize?)
|
|
(raise-argument-error 'mk-tray "boolean?" hide-on-minimize?))
|
|
(unless (or (not on-click-cb)
|
|
(and (procedure? on-click-cb)
|
|
(procedure-arity-includes? on-click-cb 0)))
|
|
(raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb))
|
|
|
|
(define eventspace (send frame get-eventspace))
|
|
(call-in-eventspace
|
|
eventspace
|
|
(λ ()
|
|
(define hwnd (send frame get-handle))
|
|
(unless hwnd
|
|
(error 'mk-tray "the frame does not have a native HWND"))
|
|
|
|
(let* ([id (allocate-tray-id)]
|
|
[callback-message (+ WM_APP id)]
|
|
[icon (load-icon icon-file)]
|
|
[t (tray frame
|
|
hwnd
|
|
id
|
|
callback-message
|
|
on-click-cb
|
|
hide-on-minimize?
|
|
eventspace
|
|
(make-os-async-channel)
|
|
#f
|
|
#f
|
|
icon
|
|
#f
|
|
#f)]
|
|
[subclass-proc
|
|
(function-ptr (make-subclass-proc t) _SUBCLASSPROC)])
|
|
;; WM_APP through 0xBFFF is reserved for application-private messages.
|
|
(when (> callback-message #xbfff)
|
|
(DestroyIcon icon)
|
|
(error 'mk-tray
|
|
"too many simultaneously addressable tray callback messages"))
|
|
|
|
(set-tray-subclass-proc! t subclass-proc)
|
|
(start-event-thread! t)
|
|
|
|
(unless (bool-result?
|
|
(SetWindowSubclass hwnd subclass-proc id 0))
|
|
(os-async-channel-put (tray-event-channel t) 'close)
|
|
(DestroyIcon icon)
|
|
(error 'mk-tray "SetWindowSubclass failed for the Racket frame"))
|
|
|
|
(with-handlers ([exn?
|
|
(λ (exn)
|
|
(RemoveWindowSubclass hwnd subclass-proc id)
|
|
(os-async-channel-put (tray-event-channel t) 'close)
|
|
(DestroyIcon icon)
|
|
(raise exn))])
|
|
(define frame-label (send frame get-label))
|
|
(add-notify-icon! t icon
|
|
(if (string? frame-label) frame-label "Racket"))
|
|
t)))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Remove a tray icon and release all native resources owned by it.
|
|
; pre : t is a tray object; calling tray-close repeatedly is allowed.
|
|
; post : The shell icon is removed, the HWND subclass is detached, the HICON
|
|
; is destroyed, the tray is marked closed, and its event thread is
|
|
; told to stop.
|
|
; result : void.
|
|
; internals:
|
|
; Cleanup runs in the frame eventspace so subclass removal happens on
|
|
; the window-owning GUI thread. The closed? check makes cleanup
|
|
; idempotent and avoids double-destroying the HICON.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (tray-close t)
|
|
(unless (tray? t)
|
|
(raise-argument-error 'tray-close "tray?" t))
|
|
(unless (tray-closed? t)
|
|
(call-in-eventspace
|
|
(tray-eventspace t)
|
|
(λ ()
|
|
(unless (tray-closed? t)
|
|
(let ([data
|
|
(make-notify-data (tray-hwnd t)
|
|
(tray-id t)
|
|
(tray-callback-message t)
|
|
(tray-icon t))])
|
|
(Shell_NotifyIconW NIM_DELETE data)
|
|
(RemoveWindowSubclass (tray-hwnd t)
|
|
(tray-subclass-proc t)
|
|
(tray-id t))
|
|
(when (tray-icon t)
|
|
(DestroyIcon (tray-icon t))
|
|
(set-tray-icon! t #f))
|
|
(set-tray-closed?! t #t)
|
|
(os-async-channel-put (tray-event-channel t) 'close))))))
|
|
(void))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Replace the image of an existing notification-area icon.
|
|
; pre : t is an open tray and icon-file names a readable .ico or .png file.
|
|
; post : On success the shell and tray object use the new HICON and the old
|
|
; HICON is destroyed. On failure the new HICON is destroyed and the
|
|
; existing tray icon remains unchanged.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; NIM_MODIFY is issued with only NIF_ICON set. Ownership is swapped
|
|
; only after Windows accepts the new native icon.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (tray-set-icon! t icon-file)
|
|
(check-open-tray 'tray-set-icon! t)
|
|
(call-in-eventspace
|
|
(tray-eventspace t)
|
|
(λ ()
|
|
(define new-icon (load-icon icon-file))
|
|
(define data
|
|
(make-notify-data (tray-hwnd t)
|
|
(tray-id t)
|
|
(tray-callback-message t)
|
|
new-icon))
|
|
(set-NOTIFYICONDATAW-uFlags! data NIF_ICON)
|
|
(cond
|
|
[(bool-result? (Shell_NotifyIconW NIM_MODIFY data))
|
|
(let ([old-icon (tray-icon t)])
|
|
(set-tray-icon! t new-icon)
|
|
(when old-icon
|
|
(DestroyIcon old-icon)))]
|
|
[else
|
|
(DestroyIcon new-icon)
|
|
(error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")]))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Associate a context menu with an existing tray object.
|
|
; pre : t is an open tray and menu-spec is accepted by
|
|
; menu-spec->popup-menu.
|
|
; post : tray-menu contains #f or a popup-menu% ready to be shown on the
|
|
; frame eventspace when Windows reports WM_CONTEXTMENU.
|
|
; result : void.
|
|
; internals:
|
|
; Menu creation is performed in the frame eventspace because Racket
|
|
; GUI objects must belong to the appropriate GUI eventspace.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (tray-set-menu! t menu-spec)
|
|
(check-open-tray 'tray-set-menu! t)
|
|
(call-in-eventspace
|
|
(tray-eventspace t)
|
|
(λ ()
|
|
(set-tray-menu! t (menu-spec->popup-menu menu-spec))))
|
|
(void))
|