Power-Programmierung/CD1.mdf/pascal/library/windows/printeps/epsprint.pas

Pascal/Delphi Source File | 1994-06-06 | 16KB | 555 lines

unit EpsPrint;

{----------------------------------------------------------------------------}
{ Version 1.00 - 06 Jun 94 - S A Schafer                                     }
{    original release                                                        }
{----------------------------------------------------------------------------}

interface

uses
  Objects,WinTypes,WinProcs,OPrinter,Strings;

type

  { tEpsPrinter is a simple descendant of tPrinter. The only change is the
    addition of the IsPostScriptCapable method, which determines whether or
    not the printer device context associated with the object is capable of
    PostScript printing. }

  pEpsPrinter = ^tEpsPrinter;
  tEpsPrinter = object (tPrinter)
    public
      function IsPostScriptCapable: Boolean;
    end;

  { tEps encapsulates an EPS image at the file level. The only public
    methods are the Init constructor and the Done destructor. tEps
    automatically strips the preview header from an EPS image, if one is
    present. }

  pEps = ^tEps;
  tEps = object (tObject)
    public
      constructor Init (FileName: pChar);
      destructor Done; virtual;
    private
      Xll,Yll,Xur,Yur: Integer;
      Stream: pStream;
      function GetBoundingBox: Boolean;
      procedure GetLine (P: pChar; Length: Word);
      procedure GetText (var Buf; Length: Word);
      procedure Reset;
      procedure SendBody (DC: hDC);
      procedure SendText (DC: hDC; Text: pChar);
    end;

  { tImage encapsulates a _transformed_ EPS image; that is, an EPS image
    plus the information necessary to place the image on the page in the
    desired location, size and orientation. aRotationAngle is given in
    degrees, and is rounded to a multiple of 90 degrees. aLeft and aBottom
    are given in inches, and set the desired position of the lower left
    corner of the image, relative to the lower left corner of the page.
    aWidth and aHeight set the desired width and height of the image. aLeft,
    aBottom, aWidth and aHeight all refer to the image in its "normal"
    orientation, _before_ rotation. For example, if the image is rotated 180
    degrees, the image's "lower left" corner is located at the upper right.
    A negative value for aWidth or aHeight will mirror the image about the
    corresponding axis.

    Note: The purpose of having a separate tEps object, rather than simply
    folding tEps into tImage, is that it allows one to place more than one
    copy of an EPS image, possibly transformed in different ways, on a
    single page, while maintaining only a single reference to the EPS file. }

  pImage = ^tImage;
  tImage = object (tObject)
    public
      constructor Init (aEps: pEps; aRotationAngle: Integer; aLeft,aBottom,
        aWidth,aHeight: Single);
      procedure Send (DC: hDC);
    private
      RotationAngle: Single;
      Left,Bottom,Width,Height: Single;
      Eps: pEps;
      procedure SendBody (DC: hDC);
      procedure SendHeader (DC: hDC);
      procedure SendTrailer (DC: hDC);
      procedure SendTransformation (DC: hDC);
    end;

implementation

const

  { These are some characters that need to be treated specially. }

  NUL = #00;
  TAB = #09;
  LF  = #10;
  FF  = #12;
  CR  = #13;
  SP  = #32;

  { Build some useful sets of these special characters. }

  NewLine    = [LF,CR];
  WhiteSpace = [NUL,TAB,LF,FF,CR,SP];

  { The following strings are sent to the printer driver at various times.
    BeginEPS saves the state of the PostScript virtual machine, resets the
    graphics state to the default, pushes a fresh copy of userdict on the
    dictionary stack, and disables the showpage operator. EndEPS undoes all
    of the changes made by BeginEPS. BeginDoc and EndDoc are comments which
    are used to delimit the body of the EPS file; they are required by the
    Adobe document structuring conventions, but are otherwise not
    significant. }

  BeginEPS    = 'userdict /EPSPRINT save put initgraphics userdict begin ' +
                '/showpage {} def'+ CR + LF;
  EndEPS      = 'end clear userdict /EPSPRINT get restore' + CR + LF;
  BeginDoc    = '%%BeginDocument: EpsPrint 1.0' + CR + LF;
  EndDoc      = '%%EndDocument' + CR + LF;

  { This is what the first part of a bounding box comment looks like; we
    will use this when searching for the bounding box info. }

  BoundingBox = '%%BoundingBox: ';

  { Before sending an EPS image, we will reset the PostScript virtual
    machine to the default state, which means that the unit of measure will
    be an Adobe point, equal to 1/72 inch (approximately the same as a
    printer's point). }

  DefaultScale = 72;

  { We will need a couple of buffers, of nominal size. }

  BufSize = 8192;

type

  { tBufRec is a general-purpose text buffer record whose fields are laid
    out in the format that the PASSTHROUGH printer escape likes to see. }

  pBufRec = ^tBufRec;
  tBufRec = record
    Len: Word;
    Buf: array[0..BufSize - 1] of Byte;
    end;

  { StrDel is a simple text deletion routine; it will delete Length
    characters from a pChar, starting at character number Start. No error-
    checking is performed. }

procedure StrDel (Dest: pChar; Start,Length: Word);

begin
Move (Dest[Start + Length],Dest[Start],StrLen (Dest) - (Start + Length) + 1);
end;

{ ParseInt parses an integer from the beginning of the pChar string P and
  places the result in N. Leading whitespace is ignored, and the end of the
  integer is signified by whitespace or end-of-string. ParseInt returns True
  if the string is successfully parsed, and False otherwise. }

function ParseInt (P: pChar; var N: Integer): Boolean;

var
  S: array[0..7] of Char;
  I,ErrCode: Integer;

begin
while P[0] in WhiteSpace do StrDel (P,0,1);
I := 0;
while (StrLen (P) > 0) and not (P[0] in WhiteSpace) and (I < 6) do
  begin
  S[I] := P[0];
  StrDel (P,0,1);
  Inc (I);
  end;
S[I] := NUL;
Val (S,N,ErrCode);
ParseInt := ErrCode = 0;
end;

{--tEpsPrinter---------------------------------------------------------------}

{ tEpsPrinter.IsPostScriptCapable returns True if the printer device context
  associated with this tEpsPrinter object supports PostScript printing, and
  False otherwise. It is assumed that the device context supports PostScript
  printing if it supports the GETTECHNOLOGY and PASSTHROUGH escapes, and if
  the technology string returned by the GETTECHNOLOGY escape contains the
  substring "PostScript". }

function tEpsPrinter.IsPostScriptCapable: Boolean;

var
  TechStr: array[0..79] of Char;
  EscapeID: Integer;
  DC: hDC;

begin

{ Create a (temporary) DC. }

DC := GetDC;
EscapeID := PASSTHROUGH;
IsPostScriptCapable := (Escape (DC,GETTECHNOLOGY,0,nil,@TechStr) <> 0) and
  (Escape (DC,QUERYESCSUPPORT,SizeOf (Integer),@EscapeID,nil) <> 0) and
  (StrPos (TechStr,'PostScript') <> nil);

{ Dispose of the temporary DC. }

DeleteDC (DC);
end;

{--tEps----------------------------------------------------------------------}

{ tEps.Init sets up a stream associated with the EPS file named in FileName.
  It checks to see whether a preview header is present, and if so, copies
  the PostScript portion of the file to a memory stream, discarding the
  preview header and preview image. Finally, it obtains the bounding box of
  the EPS image. }

constructor tEps.Init (FileName: pChar);

const

{ An EPS file containing a preview header must begin with the following
  4-byte signature. }

  EpsSig = $C6D3D0C5;

{ tEpsHeader shows the layout of an EPS preview header. }

type
  tEpsHeader = record
    Signature: LongInt;
    PsStart,PsLength: LongInt;
    MfStart,MfLength: LongInt;
    TfStart,TfLength: LongInt;
    CheckSum: Word;
    end;

var
  Stripped: pStream;
  Header: tEpsHeader;
  Count: LongInt;
  Buffer: Pointer;

begin
inherited Init;
Stream := New (pBufStream,Init (FileName,stOpenRead,BufSize));
if Stream^.Status <> stOk then Fail
else begin

  { Grab the preview header (assuming one is there). }

  Stream^.Read (Header,SizeOf (Header));

  { If the signature matches, then... }

  with Header do if Signature = EpsSig then
    begin

    { Set up a memory stream. }

    Stripped := New (pMemoryStream,Init (PsLength,BufSize));

    { Copy the PostScript code from the original EPS file to the memory
      stream. }

    Stream^.Seek (PsStart);
    GetMem (Buffer,BufSize);
    while PsLength > 0 do
      begin
      if PsLength > BufSize then Count := BufSize
      else Count := PsLength;
      Stream^.Read (Buffer^,Count);
      Stripped^.Write (Buffer^,Count);
      Dec (PsLength,Count);
      end;
    FreeMem (Buffer,BufSize);

    { Dispose of the original stream (i.e., close the EPS file). }

    Dispose (Stream,Done);

    { Set the Stream field to point to the memory stream instead. }

    Stream := Stripped;
    end;

  { Locate and parse the %%BoundingBox comment from the PostScript code. }

  if not GetBoundingBox then Fail;
  end;
end;

destructor tEps.Done;

begin
Dispose (Stream,Done);
inherited Done;
end;

{ tEps.GetBoundingBox searches the EPS file for a valid %%BoundingBox
  comment. If it finds one, it parses the comment and extracts the bounding
  box information into the Xll, Yll, Xur and Yur fields. GetBoundingBox
  returns True if a valid %%BoundingBox comment is found and successfully
  parsed, and False otherwise. }

function tEps.GetBoundingBox: Boolean;

var
  P: pChar;
  Found: Boolean;

begin
Reset;
GetMem (P,256);
Found := False;
repeat

  { Retrieve a line from the EPS file. }

  GetLine (P,255);

  { If it contains the BoundingBox string, then... }

  if StrLComp (P,BoundingBox,Length (BoundingBox)) = 0 then
    begin

    { Stript off the BoundingBox part }

    StrDel (P,0,Length (BoundingBox));

    { If the bounding box comment does _not_ contain the substring
      '(atend)', we will assume that it is a valid bounding box comment, and
      proceed to parse it. Otherwise, we'll move on to the next line. }

    if StrComp (P,'(atend)') <> 0 then
      begin

      { The first number should be Xll. }

      Found := ParseInt (P,Xll);

      { And so on. }

      if Found then Found := ParseInt (P,Yll);
      if Found then Found := ParseInt (P,Xur);
      if Found then Found := ParseInt (P,Yur);
      end;
    end;

  { Keep trying until a valid bounding box is obtained or we reach end of
    file. }

  until Found or (StrLen (P) = 0);
FreeMem (P,256);
Reset;
GetBoundingBox := Found;
end;

{ tEps.GetLine reads characters from the Stream (i.e., the EPS file) and
  builds a string representing one line of the original text file. The end
  of a line is signified by the presence of a character from the NewLine
  set. If the line is longer than Length, only the first Length characters
  are returned; one or more subsequent calls to GetLine will return the
  remainder of the line. GetLine strips leading whitespace and trailing
  newline characters from the string. GetLine returns a null string if
  Stream's file pointer is at end-of-file. }

procedure tEps.GetLine (P: pChar; Length: Word);

type
  tStates = (sStart,sReading,sEnd,sDone);

var
  C: Char;
  I: Integer;
  State: tStates;

begin
I := 0;
State := sStart;
repeat
  case State of

    { State = sStart: Strip leading whitespace. }

    sStart: begin
      Stream^.Read (C,SizeOf (C));
      if Stream^.Status <> stOk then State := sEnd
      else if not (C in WhiteSpace) then State := sReading;
      end;

    { State = sReading: Read characters from stream and append to the return
      string. }

    sReading: begin
      P[I] := C;
      Inc (I);
      if I >= Length then State := sEnd
      else begin
        Stream^.Read (C,SizeOf (C));
        if (Stream^.Status <> stOk) or (C in NewLine) then State := sEnd;
        end;
      end;

    { State = sEnd: Add a trailing NUL character to the return string. }

    sEnd: begin
      P[I] := NUL;
      Stream^.Reset;
      State := sDone;
      end;
    end;
  until State = sDone;
end;

{ tEps.GetText reads Length characters from Stream and inserts them into
  Buf. No error-checking is performed. }

procedure tEps.GetText (var Buf; Length: Word);

begin
Stream^.Read (Buf,Length);
end;

{ tEps.Reset sets Stream's file pointer to zero (beginning of the file). }

procedure tEps.Reset;

begin
Stream^.Seek (0);
end;

{ tEps.SendBody sends the full body of PostScript code to the printer
  device context. }

procedure tEps.SendBody (DC: hDC);

var
  Buffer: pBufRec;
  Count,Size: LongInt;

begin
SendText (DC,BeginDoc);
New (Buffer);
Reset;
Size := Stream^.GetSize;
while Size > 0 do
  begin
  if Size > BufSize then Count := BufSize
  else Count := Size;
  GetText (Buffer^.Buf,Count);
  Buffer^.Len := Count;
  Escape (DC,PASSTHROUGH,0,Buffer,nil);
  Size := Size - Count;
  end;
Dispose (Buffer);
SendText (DC,EndDoc);
end;

{ tEps.SendText sends the text specified in Text to the printer device
  context. }

procedure tEps.SendText (DC: hDC; Text: pChar);

var
  Buffer: pBufRec;

begin
GetMem (Buffer,StrLen (Text) + SizeOf (Word));
Buffer^.Len := StrLen (Text);
Move (Text^,Buffer^.Buf,Buffer^.Len);
Escape (DC,PASSTHROUGH,0,Buffer,nil);
FreeMem (Buffer,StrLen (Text) + SizeOf (Word));
end;

{--tImage--------------------------------------------------------------------}

constructor tImage.Init (aEps: pEps; aRotationAngle: Integer; aLeft,aBottom,
  aWidth,aHeight: Single);

begin
inherited Init;
Eps := aEps;

{ The rotation angle is rounded to the nearest multiple of 90 degrees;
  rotation about an arbitrary angle is left as an exercise for the reader. }

RotationAngle := 90 * Round (aRotationAngle / 90);
Left := aLeft;
Bottom := aBottom;
Width := aWidth;
Height := aHeight;
end;

{ tImage.Send transmits the EPS data to the printer device context, along
  with the necessary header, placement information and trailer. }

procedure tImage.Send (DC: hDC);

begin
SendHeader (DC);
SendTransformation (DC);
SendBody (DC);
SendTrailer (DC);
end;

procedure tImage.SendBody (DC: hDC);

begin
Eps^.SendBody (DC);
end;

procedure tImage.SendHeader (DC: hDC);

begin
Eps^.SendText (DC,BeginEps);
end;

procedure tImage.SendTrailer (DC: hDC);

begin
Eps^.SendText (DC,EndEps);
end;

{ tImage.SendTransformation calculates the translation, scaling and rotation
  needed to transform the original EPS image to its final location, size and
  orientation, and sends the PostScript commands required to perform this
  transformation to the printer device context. }

procedure tImage.SendTransformation (DC: hDC);

var
  L,B,W,H,A: String[10];
  S: String[40];

begin
with Eps^ do
  begin
  Str ((DefaultScale * Left):0:2,L);
  Str ((DefaultScale * Bottom):0:2,B);
  S := L + ' ' + B + ' translate ' + NUL;
  SendText (DC,@S[1]);
  Str (RotationAngle:0:0,A);
  S := A + ' rotate ' + NUL;
  SendText (DC,@S[1]);
  Str ((DefaultScale * Width / (Xur - Xll)):0:2,W);
  Str ((DefaultScale * Height / (Yur - Yll)):0:2,H);
  S := W + ' ' + H + ' scale ' + NUL;
  SendText (DC,@S[1]);
  Str ((-1.0 * Xll):0:2,L);
  Str ((-1.0 * Yll):0:2,B);
  S := L + ' ' + B + ' translate' + CR + LF + NUL;
  SendText (DC,@S[1]);
  end;
end;

end.