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

..

Browse Source 
original commit: dde919cd21bef50995237711174f50499a0f866c
This commit is contained in:
Robby Findler 2003-06-22 21:32:42 +00:00
parent 0e01b0fbd4
commit 17fe8e25a2
1 changed files with 11 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/framework/splash.ss
View File

@ -2,18 +2,21 @@
(module splash mzscheme (module splash mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "file.ss") (lib "file.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred"))
(lib "contract.ss"))
(provide get-splash-bitmap set-splash-bitmap (provide get-splash-bitmap
get-splash-canvas get-splash-eventspace get-dropped-files set-splash-bitmap
start-splash shutdown-splash close-splash add-splash-icon set-splash-char-observer) get-splash-canvas
get-splash-eventspace
start-splash
shutdown-splash
close-splash
add-splash-icon
set-splash-char-observer)
(define splash-filename #f) (define splash-filename #f)
(define splash-bitmap #f) (define splash-bitmap #f)
(define splash-eventspace (make-eventspace)) (define splash-eventspace (make-eventspace))
(define dropped-files null)
(define (get-splash-bitmap) splash-bitmap) (define (get-splash-bitmap) splash-bitmap)
(define (set-splash-bitmap bm) (define (set-splash-bitmap bm)
@ -21,7 +24,6 @@
(send splash-canvas on-paint)) (send splash-canvas on-paint))
(define (get-splash-canvas) splash-canvas) (define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace) (define (get-splash-eventspace) splash-eventspace)
(define (get-dropped-files) dropped-files)
(define char-observer void) (define char-observer void)
(define (set-splash-char-observer proc) (define (set-splash-char-observer proc)
@ -44,7 +46,6 @@
(set! splash-bitmap #f) (set! splash-bitmap #f)
(set! splash-canvas #f) (set! splash-canvas #f)
(set! splash-eventspace #f) (set! splash-eventspace #f)
(set! dropped-files null)
(k (void))) (k (void)))
(unless splash-filename (unless splash-filename
@ -186,10 +187,7 @@
(define splash-frame% (define splash-frame%
(class frame% (class frame%
(override on-drop-file on-close) (define/override (on-close)
(define (on-drop-file filename)
(set! dropped-files (cons filename dropped-files)))
(define (on-close)
(when quit-on-close? (when quit-on-close?
(exit))) (exit)))
(super-instantiate ()))) (super-instantiate ())))
@ -217,7 +215,6 @@
(label splash-title) (label splash-title)
(style '(no-resize-border))))) (style '(no-resize-border)))))
(send splash-frame set-alignment 'center 'center) (send splash-frame set-alignment 'center 'center)
(send splash-frame accept-drop-files #t)
(define panel (make-object vertical-pane% splash-frame)) (define panel (make-object vertical-pane% splash-frame))
(define splash-canvas (make-object splash-canvas% panel)) (define splash-canvas (make-object splash-canvas% panel))