window-hardcopy (LONG source code)

[lynch@aristotle.ils.nwu.edu]

Recently, there has been some discussion about window-hardcopy being
something that could be defined in a general way.
Here is my first attempt at it.
It actually works for the examples given, but not for my real case (I get
blank pages).
It *may* work for you.
I only ask that you send improvements to me if you make any.

(require :quickdraw)
;This is available by FTP.  It may not even *really* be needed.
(require :oou-init)

(defclass printable (window)
  ()
  (:documentation "A mix-in class that makes a window printable.")
)

(defmethod window-hardcopy ((view printable) &optional show-dialog?)
  (declare (ignore show-dialog?))
  ;There are *lots* of unwind-protects and #_PrError checks with non-local
exits
  ;in this code.  There are probably more than need to be there, but I
figured
  ;better safe than sorry.
  (let ((ppageframe (%null-ptr))
        (pdevbuf (%null-ptr))
        (SpoolPort (%null-ptr))
        (viewPort (wptr view))
        error-check
        prRecHdl
        PPrPort
       )
    (unwind-protect
      ;Make sure we #_PrClose.
      (progn
        (#_PrOpen)
        (setq error-check (#_PrError))
        ;Does (#_PrError) clear the error code?  Assume so for now.
        (unless (zerop error-check)
          (return-from window-hardcopy (values :pr-open-error error-check))
        )
        (unwind-protect
          (progn
            ;Make sure we #_DisposeHandle
            (setq prRecHdl (#_NewHandle 124))
            ;Actually, I should get the handle from the resource file of
(window-filename view)
            ;if there is one.  This I might actually do soon.
            (unless (= 124 (#_GetHandleSize prRecHdl))
              (return-from window-hardcopy :new-handle-error)
            )
            (#_PrintDefault PrRecHdl)
            (setq error-check (#_PrError))
            (unless (zerop error-check)
              (return-from window-hardcopy (values :print-default-error
error-check))
            )
            (when (#_PrJobDialog prRecHdl)
              (setq error-check (#_PrError))
              (unless (zerop error-check)
                (return-from window-hardcopy (values :pr-job-dialog-error
error-check))
              )
              ;#_PrOpenDoc is supposed to set the port, but who restores
it?
              ;Hence, the with-port below.
              (with-port viewPort
                (unwind-protect
                  ;Make sure we #_PrCloseDoc
                  (progn
                    (setq PPrPort (#_PrOpenDoc prRecHdl (%null-ptr)
(%null-ptr)))
                    (setq error-check (#_PrError))
                    (unless (zerop error-check)
                      (return-from window-hardcopy (values
:pr-open-doc-error error-check))
                    )
                    (unwind-protect
                      ;Here I should do some looping if the view is larger
than 1 page.
                      (progn
                        (#_PrOpenPage PPrPort ppageframe)
                        (setq error-check (#_PrError))
                        (unless (zerop error-check)
                          (return-from window-hardcopy (values
:pr-open-page-error error-check))
                        )

                        ;draw
                        ;This works fine for my small examples, but does
nothing for
                        ;my real case.  I was told to do a copy-bits, but
that did nothing
                        ;for either case.
                        (view-draw-contents view)

                      )
                      (#_PrClosePage PPrPort)
                      (setq error-check (#_PrError))
                      (unless (zerop error-check)
                        (return-from window-hardcopy (values
:pr-close-page-error error-check))
                      )
                  ) )
                  (#_PrCloseDoc PPrPort)
                  (setq error-check (#_PrError))
                  (unless (zerop error-check)
                    (return-from window-hardcopy (values
:pr-close-doc-error error-check))
                  )
              ) )
              ;If printing is spooled, we need to call prPicFile
              (when (= (rref prRecHdl :TPrint.prJob.bJDocLoop)
#$bSpoolLoop)
                (rlet ((myStRec :TPrStatus))
                  (#_prPicFile prRecHdl SpoolPort (%null-ptr) pdevbuf
myStRec)
          ) ) ) )
          (when (handlep prRecHdl) (#_DisposeHandle prRecHdl))
      ) )
      (#_PrClose)
      (setq error-check (#_PrError))
      (unless (zerop error-check)
        (return-from window-hardcopy (values :pr-close-error error-check))
) ) ) )


#|

(defclass sample1 (printable window)
  ()
  (:default-initargs
    :view-size #@(100 100)
    :view-position (make-point (- *screen-width* 120) 100)
  )
)

(defmethod view-draw-contents :after ((view sample1))
  (rlet ((rect :rect :topleft #@(10 10) :bottomright #@(50 50)))
    (#_PaintRect rect)
  )
  (let ((h (#_GetIcon 0)))
    (rlet ((rect :rect :topleft #@(60 10) :bottomright #@(92 42)))
      (#_PlotIcon rect h)
) ) )

(defparameter *sample1* (make-instance 'sample1))

(window-hardcopy *sample1*)

(defclass sample2 (printable dialog)
  ()
  (:default-initargs
    :view-size #@(100 100)
    :view-position (make-point (- *screen-width* 120) 220)
  )
)

(defmethod view-draw-contents :after ((view sample2))
  (rlet ((rect :rect :topleft #@(10 10) :bottomright #@(50 50)))
    (#_PaintRect rect)
  )
  (let ((h (#_GetIcon 1)))
    (rlet ((rect :rect :topleft #@(60 10) :bottomright #@(92 42)))
      (#_PlotIcon rect h)
) ) )

(defparameter *sample2* (make-instance 'sample2))

(window-hardcopy *sample2*)

(defclass sample3 (printable color-dialog)
  ()
  (:default-initargs
    :view-size #@(100 100)
    :view-position (make-point (- *screen-width* 120) 340)
  )
)

(defmethod view-draw-contents :after ((view sample3))
  (rlet ((rect :rect :topleft #@(10 10) :bottomright #@(50 50)))
    (#_PaintRect rect)
  )
  (let ((h (#_GetIcon 2)))
    (rlet ((rect :rect :topleft #@(60 10) :bottomright #@(92 42)))
      (#_PlotIcon rect h)
) ) )

(defparameter *sample3* (make-instance 'sample3))

(window-hardcopy *sample3*)


|#
"TANSTAAFL" Rich lynch@ils.nwu.edu