diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index fddafc46..f7d95e2a 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -25,6 +25,7 @@ brush% brush-list% button% + can-get-page-setup-from-user? canvas% canvas<%> check-box% @@ -89,6 +90,7 @@ get-file get-file-list get-font-from-user + get-page-setup-from-user get-panel-background get-ps-setup-from-user get-resource diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 56eb642a..7f988841 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -239,6 +239,8 @@ get-choices-from-user get-text-from-user get-ps-setup-from-user + get-page-setup-from-user + can-get-page-setup-from-user? play-sound get-display-size get-display-left-top-inset diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 162ccf76..25836e11 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -1008,8 +1008,6 @@ get-data on-replaced) (define-class ps-setup% object% () - show-native - can-show-native? copy-from set-margin set-editor-margin @@ -1033,6 +1031,8 @@ get-preview-command get-file get-command) + (define-function show-print-setup) + (define-function can-show-print-setup?) (define-class pasteboard% editor% #f set-scroll-step get-scroll-step diff --git a/collects/mred/private/moredialogs.ss b/collects/mred/private/moredialogs.ss index c4434878..46e65892 100644 --- a/collects/mred/private/moredialogs.ss +++ b/collects/mred/private/moredialogs.ss @@ -19,6 +19,8 @@ "mrtextfield.ss") (provide get-ps-setup-from-user + get-page-setup-from-user + can-get-page-setup-from-user? get-text-from-user get-choices-from-user get-color-from-user) @@ -139,6 +141,28 @@ s) #f)])) + (define get-page-setup-from-user + (case-lambda + [() (get-page-setup-from-user #f #f #f null)] + [(message) (get-page-setup-from-user message #f #f null)] + [(message parent) (get-page-setup-from-user message parent #f null)] + [(message parent pss) (get-page-setup-from-user message parent pss null)] + [(message parent pss-in style) + (check-label-string/false 'get-page-setup-from-user message) + (check-top-level-parent/false 'get-page-setup-from-user parent) + (check-instance 'get-page-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in) + (check-style 'get-page-setup-from-user #f null style) + + (and (wx:can-show-print-setup?) + (let ([s (make-object wx:ps-setup%)]) + (send s copy-from (or pss-in (wx:current-ps-setup))) + (and (parameterize ([wx:current-ps-setup s]) + (wx:show-print-setup parent)) + s)))])) + + (define (can-get-page-setup-from-user?) + (wx:can-show-print-setup?)) + (define get-text-from-user (case-lambda [(title message) (get-text-from-user title message #f "" null)]