(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated "29-Dec-87 14:01:40" |{EG:PARC:XEROX}<JELLINEK>LISPUSERS>HARDCOPY-RETAIN.;2| 6163
|changes| |to:| (functions hardcopyimagew.tofile&printer xcl-user::install-option)
(vars hardcopy-retaincoms)
|previous| |date:| "29-Dec-87 12:27:25" |{EG:PARC:XEROX}<JELLINEK>LISPUSERS>HARDCOPY-RETAIN.;1|
)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(prettycomprint hardcopy-retaincoms)
(rpaqq hardcopy-retaincoms ((functions hardcopyimagew.tofile&printer xcl-user::install-option)
(p (xcl-user::install-option))))
(cl:defun hardcopyimagew.tofile&printer (&optional xcl-user::window)
"Send hardcopy of WINDOW to a printer and a file."
(let
((xcl-user::result (|GetImageFile|)))
(cl:when
xcl-user::result
(let ((xcl-user::printer-name (|GetPrinterName|)))
(destructuring-bind
(xcl-user::file . type)
xcl-user::result
(hardcopy.somehow xcl-user::window xcl-user::file type)
(cl:when xcl-user::printer-name
(let ((xcl-user::full-name (packfilename.string
'host
(cl:pathname-host xcl-user::file)
'device
(cl:pathname-device xcl-user::file)
'directory
(cl:pathname-directory xcl-user::file)
'name
(cl:pathname-name xcl-user::file)
'extension
(or (cl:first (cl:second (cl:assoc 'extension
(cl:rest (cl:assoc
type
printfiletypes
)))))
type)
'body
(cl:namestring *default-pathname-defaults*))))
(send.file.to.printer xcl-user::full-name xcl-user::printer-name))))))))
(cl:defun install-option nil "Install the new Hardcopy option."
(cl:labels ((xcl-user::get-subitems (xcl-user::item)
(and (eq (cl:first (cl:fourth xcl-user::item))
'subitems)
(cl:rest (cl:fourth xcl-user::item))))
(xcl-user::find-place-wm
(xcl-user::item)
(let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item)))
(cl:when xcl-user::subitems
(cl:if (eq (car xcl-user::item)
'|Hardcopy|)
(cl:unless (* \; "Install if not already there.")
(cl:find 'hardcopyimagew.tofile&printer xcl-user::subitems
:key #'(cl:lambda (xcl-user::x)
(cl:second (cl:second xcl-user::x)))
:test #'eq)
(nconc xcl-user::subitems (list (list
"To a file and a printer"
''
hardcopyimagew.tofile&printer
"Sends image to a printer of your choosing, retaining the printer version of the file."
))))
(cl:mapc #'xcl-user::find-place-wm xcl-user::subitems)))))
(xcl-user::find-place-bm
(xcl-user::item)
(let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item)))
(cl:when xcl-user::subitems
(cl:if (eq (car xcl-user::item)
'|Hardcopy|)
(cl:unless (* \; "Install if not already there.")
(cl:find 'hardcopyimagew.tofile&printer xcl-user::subitems
:key #'(cl:lambda (xcl-user::x)
(cl:first (cl:second (cl:second
xcl-user::x
)))) :test
#'eq)
(nconc xcl-user::subitems
(list (list "To a file and a printer"
''(hardcopyimagew.tofile&printer)
"Sends image to a printer of your choosing, retaining the printer version of the file."
))))
(cl:mapc #'xcl-user::find-place-bm xcl-user::subitems))))))
(cl:mapc #'xcl-user::find-place-wm |WindowMenuCommands|)
(cl:mapc #'xcl-user::find-place-bm |BackgroundMenuCommands|)
(cl:setq |WindowMenu| nil)
(cl:setq |BackgroundMenu| nil)))
(xcl-user::install-option)
(putprops hardcopy-retain copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
(filemap (nil)))
stop