diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index ea3946d4..cfbdeb1f 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -36,7 +36,8 @@ make-root-area-container close)) (define basic-mixin - (mixin (frame<%>) (basic<%>) args + (mixin (frame<%>) (basic<%>) + (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) (rename [super-can-close? can-close?] [super-on-close on-close] [super-on-focus on-focus]) @@ -71,12 +72,18 @@ (when (can-close?) (on-close) (show #f)))]) + (sequence - (apply super-init args) + (let ([mdi-parent (send (group:get-the-frame-group) get-mdi-parent)]) + (super-init label + (or parent mdi-parent) + width height x y + (cond + [parent style] + [mdi-parent (cons 'mdi-child style)] + [else style]))) - ;; must make menu before inserting frame into group - ;; or initial windows menu will be wrong - (make-object menu% "Windows" (make-object (get-menu-bar%) this)) + (make-object (get-menu-bar%) this) (send (group:get-the-frame-group) insert-frame this)) (private [panel (make-root-area-container (get-area-container%) this)]) diff --git a/collects/framework/group.ss b/collects/framework/group.ss index e357364e..d2f0d377 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -1,11 +1,14 @@ (unit/sig framework:group^ (import mred-interfaces^ + [application : framework:application^] [frame : framework:frame^] [mzlib:function : mzlib:function^] [mzlib:file : mzlib:file^]) (define-struct frame (frame id)) + (define mdi-parent #f) + (define % (class object% () (private @@ -93,6 +96,21 @@ (set-close-menu-item-state! a-frame #t)) frames))))]) (public + + [get-mdi-parent + (lambda () + (if (eq? (system-type) 'windows) + (begin + (set! get-mdi-parent (lambda () mdi-parent)) + (set! mdi-parent (make-object frame% (application:current-app-name) + #f #f #f #f #f + '(mdi-parent))) + (send mdi-parent show #t) + mdi-parent) + (begin + (set! get-mdi-parent (lambda () #f)) + #f)))] + [set-empty-callbacks (lambda (test close-down) (set! empty-test test)