{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit Printers;

interface

uses WinTypes, SysUtils, Classes, Graphics, Forms;

type
  EPrinter = class(Exception);

  { TPrinter }

  { The printer object encapsulates the printer interface of Windows.  A print
    job is started whenever any redering is done either through a Text variable
    or the printers canvas.  This job will stay open until EndDoc is called or
    the Text variable is closed.  The title displayed in the Print Manager (and
    on network header pages) is determined by the Title property.

    EndDoc - Terminates the print job (and closes the currently open Text).
      The print job will being printing on the printer after a call to EndDoc.
    NewPage - Starts a new page and increments the PageNumber property.  The
      pen position of the Canvas is put back at (0, 0).
    Canvas - Represents the surface of the currently printing page.  Note that
      some printer do not support drawing pictures and the Draw, StretchDraw,
      and CopyRect methods might fail.
    Fonts - The list of fonts supported by the printer.  Note that TrueType
      fonts appear in this list even if the font is not supported natively on
      the printer since GDI can render them accurately for the printer.
    PageHeight - The height, in pixels, of the page.
    PageWidth - The width, in pixels, of the page.
    PageNumber - The current page number being printed.  This is incremented
      when ever the NewPage method is called.  (Note: This property can also be
      incremented when a Text variable is written, a CR is encounted on the
      last line of the page).
    PrinterIndex - Specifies which printer in the TPrinters list that is
      currently selected for printing.  Setting this property to -1 will cause
      the default printer to be selected.  If this value is changed EndDoc is
      called automatically.
    Printers - A list of the printers installed in Windows.
    Title - The title used by Windows in the Print Manager and for network
      title pages. }

  TPrinterState = (psNoHandle, psHandleIC, psHandleDC);
  TPrinterOrientation = (poPortrait, poLandscape);

  TPrinter = class(TObject)
  private
    FCanvas: TCanvas;
    FFonts: TStrings;
    FPageNumber: Integer;
    FPrinters: TStrings;
    FPrinterIndex: Integer;
    FTitle: PString;
    FPrinting: Boolean;
    FAborted: Boolean;
    State: TPrinterState;
    DC: HDC;
    DeviceMode: THandle;
    FExtDeviceMode: TExtDeviceMode;
    FDeviceHandle: THandle;
    procedure SetState(Value: TPrinterState);
    function GetCanvas: TCanvas;
    function GetFonts: TStrings;
    function GetHandle: HDC;
    function GetOrientation: TPrinterOrientation;
    function GetPageHeight: Integer;
    function GetPageWidth: Integer;
    function GetPrinterIndex: Integer;
    procedure SetPrinterIndex(Value: Integer);
    function GetPrinters: TStrings;
    function GetTitle: string;
    procedure SetOrientation(Value: TPrinterOrientation);
    procedure SetTitle(const Value: string);
    procedure SetToDefaultPrinter;
    procedure CheckPrinting(Value: Boolean);
    procedure FreePrinters;
    procedure FreeFonts;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Abort;
    procedure BeginDoc;
    procedure EndDoc;
    procedure NewPage;
    procedure GetPrinter(ADevice, ADriver, APort: PChar; var ADeviceMode: THandle);
    procedure SetPrinter(ADevice, ADriver, APort: PChar; ADeviceMode: THandle);
    property Aborted: Boolean read FAborted;
    property Canvas: TCanvas read GetCanvas;
    property Fonts: TStrings read GetFonts;
    property Handle: HDC read GetHandle;
    property Orientation: TPrinterOrientation read GetOrientation write SetOrientation;
    property PageHeight: Integer read GetPageHeight;
    property PageWidth: Integer read GetPageWidth;
    property PageNumber: Integer read FPageNumber;
    property PrinterIndex: Integer read GetPrinterIndex write SetPrinterIndex;
    property Printing: Boolean read FPrinting;
    property Printers: TStrings read GetPrinters;
    property Title: string read GetTitle write SetTitle;
  end;

var
  Printer: TPrinter;

{ AssignPrn - Assigns a Text variable to the currently selected printer.  Any
      Write or Writeln's going to that file variable will be written on the
      printer using the Canvas property's font.  A new page is automatically
      started if a CR is encountered on (or a Writeln is written to) the last
      line on the page.  Closing the text file will imply a call to the
      Printer.EndDoc method. Note: only one Text variable can be open on the
      printer at a time.  Opening a second will cause an exception.}
procedure AssignPrn(var F: Text);

implementation

uses WinProcs, Consts;

{ FetchStr }
function FetchStr(var Str: PChar): PChar;
var
  P: PChar;
begin
  Result := Str;
  if Str = nil then Exit;
  P := Str;
  while P^ = ' ' do Inc(P);
  Result := P;
  while (P^ <> #0) and (P^ <> ',') do Inc(P);
  if P^ = ',' then
  begin
    P^ := #0;
    Inc(P);
  end;
  Str := P;
end;

procedure RaiseError(MsgID: Word);
begin
  raise EPrinter.Create(LoadStr(MsgID));
end;

function AbortProc(Prn: HDC; Error: Integer): Bool; export;
begin
  Application.ProcessMessages;
  Result := not Printer.Aborted;
end;

function ValidHandle(Handle: THandle): Boolean;
var
  Count: Word;
begin
  Result := not IsBadWritePtr(Ptr(Handle, 0), Count);
end;

{ PrnRec }
{ Printer data record }
type
  PrnRec = record
    case Integer of
      1: (
        Cur: TPoint;
        Finish: TPoint;         { End of the pritable area }
        Height: Word);          { Height of the current line }
      2: (
        Tmp: array[1..16] of Char);
  end;

{ NewPage }
procedure NewPage(var Prn: PrnRec);
begin
  with Prn do
  begin
    Cur.X := 0;
    Cur.Y := 0;
    Printer.NewPage;
  end;
end;

{ NewLine }
{ Start a new line on the current page, if no more lines left start a new
  page. }
procedure NewLine(var Prn: PrnRec);

  function CharHeight: Word;
  var
    Metrics: TTextMetric;
  begin
    GetTextMetrics(Printer.Canvas.Handle, Metrics);
    CharHeight := Metrics.tmHeight;
  end;

begin
  with Prn do
  begin
    Cur.X := 0;
    if Height = 0 then
      { two new lines in a row, use the current character height }
      Inc(Cur.Y, CharHeight)
    else
      { Advance the height of the tallest font }
      Inc(Cur.Y, Height);
    if Cur.Y > (Finish.Y - (Height * 2)) then NewPage(Prn);
    Height := 0;
  end;
end;

{ PrnOutStr }
{ Print a string to the printer without regard to special characters.  These
  should handled by the caller. }
procedure PrnOutStr(var Prn: PrnRec; Text: PChar; Len: Integer);
var
  Extent: TSize;                { Size of the current text }
  L: Integer;                   { Temporary used for printing }
begin
  with Prn, Printer.Canvas do
  begin
    while Len > 0 do
    begin
      L := Len;
      GetTextExtentPoint(Handle, Text, L, Extent);

      { Wrap the text to the line }
      while (L > 0) and (Extent.cX + Cur.X > Finish.X) do
      begin
        Dec(L);
        GetTextExtentPoint(Handle, Text, L, Extent);
      end;

      { Adjust the current line height }
      if Extent.cY > Height then Height := Extent.cY + 2;

      WinProcs.TextOut(Handle, Cur.X, Cur.Y, Text, L);
      Dec(Len, L);
      Inc(Text, L);
      if Len > 0 then NewLine(Prn)
      else Inc(Cur.X, Extent.cX);
    end;
  end;
end;

{ PrnString }
{ Print a string to the printer handling special characters. }
procedure PrnString(var Prn: PrnRec; Text: PChar; Len: Integer);
var
  L: Integer;                   { Temporary used for printing }
  TabWidth: Word;               { Width (in pixels) of a tab }

  { Flush to the printer the non-specal characters found so far }
  procedure Flush;
  begin
    if L <> 0 then PrnOutStr(Prn, Text, L);
    Inc(Text, L + 1);
    Dec(Len, L + 1);
    L := 0;
  end;

  { Calculate the average character width }
  function AvgCharWidth: Word;
  var
    Metrics: TTextMetric;
  begin
    GetTextMetrics(Printer.Canvas.Handle, Metrics);
    AvgCharWidth := Metrics.tmAveCharWidth;
  end;

begin
  L := 0;
  with Prn do
  begin
    while L < Len do
    begin
      case Text[L] of
        #9:
          begin
            Flush;
            TabWidth := AvgCharWidth * 8;
            Inc(Cur.X, TabWidth - ((Cur.X + TabWidth + 1)
              mod TabWidth) + 1);
            if Cur.X > Finish.X then NewLine(Prn);
          end;
        #13: Flush;
        #10:
          begin
            Flush;
            NewLine(Prn);
          end;
        ^L:
          begin
            Flush;
            NewPage(Prn);
          end;
      else
        Inc(L);
      end;
    end;
  end;
  Flush;
end;

{ PrnInput }
{ Called when a Read or Readln is applied to a printer file. Since reading is
  illegal this routine tells the I/O system that no characters where read, which
  generates a runtime error. }
function PrnInput(var F: TTextRec): Integer; far;
begin
  with F do
  begin
    BufPos := 0;
    BufEnd := 0;
  end;
  PrnInput := 0;
end;

{ PrnOutput }
{ Called when a Write or Writeln is applied to a printer file. The calls
  PrnString to write the text in the buffer to the printer. }
function PrnOutput(var F: TTextRec): Integer; far;
begin
  with F do
  begin
    PrnString(PrnRec(UserData), PChar(BufPtr), BufPos);
    BufPos := 0;
    PrnOutput := 0;
  end;
end;

{ PrnIgnore }
{ Will ignore certain requests by the I/O system such as flush while doing an
  input. }
function PrnIgnore(var F: TTextRec): Integer; far;
begin
  PrnIgnore := 0;
end;

{ PrnClose }
{ Deallocates the resources allocated to the printer file. }
function PrnClose(var F: TTextRec): Integer; far;
begin
  with PrnRec(F.UserData) do
  begin
    Printer.EndDoc;
    PrnClose := 0;
  end;
end;

{ PrnOpen }
{ Called to open I/O on a printer file.  Sets up the TTextFile to point to
  printer I/O functions. }
function PrnOpen(var F: TTextRec): Integer; far;
const
  Blank: array[0..0] of Char = '';
begin
  with F, PrnRec(UserData) do
  begin
    if Mode = fmInput then
    begin
      InOutFunc := @PrnInput;
      FlushFunc := @PrnIgnore;
      CloseFunc := @PrnIgnore;
    end
    else
    begin
      Mode := fmOutput;
      InOutFunc := @PrnOutput;
      FlushFunc := @PrnOutput;
      CloseFunc := @PrnClose;
      Printer.BeginDoc;

      { Initialize the printer record }
      Cur.X := 0;
      Cur.Y := 0;
      Finish.X := Printer.PageWidth;
      Finish.Y := Printer.PageHeight;
      Height := 0;
    end;
    Result := 0;
  end;
end;

{ AssignPrn }
{ AssignPrn assigns a file to a printer. }
procedure AssignPrn(var F: Text);
begin
  with TTextRec(F), PrnRec(UserData) do
  begin
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @PrnOpen;
  end;
end;

{ TPrinterDevice }

type
  TPrinterDevice = class
    Driver, Device, Port: PChar;
    constructor Create(ADriver, ADevice, APort: PChar);
    destructor Destroy; override;
    function IsEqual(ADriver, ADevice, APort: PChar): Boolean;
  end;

constructor TPrinterDevice.Create(ADriver, ADevice, APort: PChar);
begin
  inherited Create;
  Driver := StrNew(ADriver);
  Device := StrNew(ADevice);
  Port := StrNew(APort);
end;

destructor TPrinterDevice.Destroy;
begin
  StrDispose(Driver);
  StrDispose(Device);
  StrDispose(Port);
end;

function TPrinterDevice.IsEqual(ADriver, ADevice, APort: PChar): Boolean;
begin
  Result := (StrComp(Driver, ADriver) = 0) and (StrComp(Device, ADevice) = 0)
    and (StrComp(Port, APort) = 0);
end;

{ TPrinterCanvas }

type
  TPrinterCanvas = class(TCanvas)
    Printer: TPrinter;
    constructor Create(APrinter: TPrinter);
    procedure CreateHandle; override;
    procedure Changing; override;
    procedure UpdateFont;
  end;

constructor TPrinterCanvas.Create(APrinter: TPrinter);
begin
  inherited Create;
  Printer := APrinter;
end;

procedure TPrinterCanvas.CreateHandle;
begin
  Printer.SetState(psHandleIC);
  UpdateFont;
  Handle:= Printer.DC;
end;

procedure TPrinterCanvas.Changing;
begin
  Printer.CheckPrinting(True);
  inherited Changing;
end;

procedure TPrinterCanvas.UpdateFont;
var
  TextMetrics: TTextMetric;
  FontSize: Integer;
begin
  FontSize := Font.Size;
  Font.PixelsPerInch := GetDeviceCaps(Printer.DC, LOGPIXELSY);
  Font.Size := FontSize;
end;

{ TPrinter }

constructor TPrinter.Create;
begin
  inherited Create;
  FPrinterIndex := -1;
end;

destructor TPrinter.Destroy;
begin
  if Printing then EndDoc;
  SetState(psNoHandle);
  FreePrinters;
  FreeFonts;
  FCanvas.Free;
  if FDeviceHandle <> 0 then FreeLibrary(FDeviceHandle);
  inherited Destroy;
end;

procedure TPrinter.SetState(Value: TPrinterState);
type
  TCreateHandleFunc = function (DriverName, DeviceName, Output: PChar; InitData:
    Pointer): HDC;
var
  CreateHandleFunc: TCreateHandleFunc;
begin
  if Value <> State then
  begin
    CreateHandleFunc := nil;
    case Value of
      psNoHandle:
        begin
          CheckPrinting(False);
          if Assigned(FCanvas) then FCanvas.Handle := 0; 
          DeleteDC(DC);
          DC := 0;
        end;
      psHandleIC:
        if State <> psHandleDC then
          CreateHandleFunc := CreateIC
        else
          Exit;
      psHandleDC:
        begin
          if FCanvas <> nil then FCanvas.Handle := 0;
          if DC <> 0 then DeleteDC(DC);
          CreateHandleFunc := CreateDC;
        end;
    end;
    if Assigned(CreateHandleFunc) then
      with TPrinterDevice(Printers.Objects[PrinterIndex]) do
      begin
        DC := CreateHandleFunc(Driver, Device, Port, Ptr(DeviceMode, 0));
        if DC = 0 then RaiseError(SInvalidPrinter);
        if FCanvas <> nil then FCanvas.Handle := DC;
      end;
    State := Value;
  end;
end;

procedure TPrinter.CheckPrinting(Value: Boolean);
begin
  if Printing <> Value then
    if Value then RaiseError(SNotPrinting)
    else RaiseError(SPrinting);
end;

procedure TPrinter.Abort;
begin
  CheckPrinting(True);
  {AbortDoc(Canvas.Handle);}
  FAborted := True;
end;

procedure TPrinter.BeginDoc;
var
  CTitle: array[0..31] of Char;
  DocInfo: TDocInfo;
begin
  CheckPrinting(False);
  SetState(psHandleDC);
  Canvas.Refresh;
  FPrinting := True;
  FAborted := False;
  FPageNumber := 1;
  StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
  with DocInfo do
  begin
    cbSize := SizeOf(DocInfo);
    lpszDocName := CTitle;
    lpszOutput := nil;
  end;
  SetAbortProc(DC, AbortProc);
  StartDoc(DC, DocInfo);
  StartPage(DC);
end;

procedure TPrinter.EndDoc;
begin
  CheckPrinting(True);
  EndPage(DC);
  if not Aborted then WinProcs.EndDoc(DC);
  FPrinting := False;
  FAborted := False;
  FPageNumber := 0;
end;

procedure TPrinter.NewPage;
begin
  CheckPrinting(True);
  EndPage(DC);
  StartPage(DC);
  Inc(FPageNumber);
  Canvas.Refresh;
end;

procedure TPrinter.GetPrinter(ADevice, ADriver, APort: PChar; var ADeviceMode: THandle);
begin
  ADeviceMode := DeviceMode;
  with TPrinterDevice(Printers.Objects[PrinterIndex]) do
  begin
    StrCopy(ADevice, Device);
    StrCopy(ADriver, Driver);
    StrCopy(APort, Port);
  end;
end;

procedure TPrinter.SetPrinter(ADevice, ADriver, APort: PChar; ADeviceMode: THandle);
var
  I, J: Integer;
  StubDevMode: TDevMode;
  P: PDevMode;
  DriverName: array[0..255] of Char;
begin
  CheckPrinting(False);
  { Forget about the old printer }
  if ADeviceMode <> DeviceMode then
  begin
    if ValidHandle(DeviceMode) then GlobalFree(DeviceMode);
    DeviceMode := ADeviceMode;
  end;
  FreeFonts;
  FExtDeviceMode := nil;
  if FDeviceHandle <> 0 then
  begin
    FreeLibrary(FDeviceHandle);
    FDeviceHandle := 0;
  end;
  SetState(psNoHandle);
  J := -1;
  for I := 0 to Printers.Count - 1 do
  begin
    if TPrinterDevice(Printers.Objects[I]).IsEqual(ADriver, ADevice, APort) then
    begin
      J := I;
      Break;
    end;
  end;
  if J = -1 then
  begin
    { For some reason, the printer is not in the [devices] list }
    J := FPrinters.Count;
    FPrinters.AddObject(Format('%s on %s', [ADevice, APort]),
      TPrinterDevice.Create(ADriver, ADevice, APort));
  end;
  FPrinterIndex := J;
  StrCat(StrCopy(DriverName, ADriver), '.DRV');
  FDeviceHandle := LoadLibrary(DriverName);
  if FDeviceHandle <= 16 then FDeviceHandle := 0;
  if FDeviceHandle <> 0 then
  begin
    @FExtDeviceMode := GetProcAddress(FDeviceHandle, 'ExtDeviceMode');
    if Assigned(FExtDeviceMode) and (DeviceMode = 0) then
    begin
      DeviceMode := GlobalAlloc(HeapAllocFlags or GMEM_ZEROINIT,
        FExtDeviceMode(0, FDeviceHandle, StubDevMode, ADevice, APort,
        StubDevMode, nil, 0));
      if DeviceMode <> 0 then
      begin
        P := Ptr(DeviceMode, 0);
        if FExtDeviceMode(0, FDeviceHandle, P^, ADevice, APort, P^, nil,
          DM_OUT_BUFFER) < 0 then
        begin
          GlobalFree(DeviceMode);
          DeviceMode := 0;
        end;
      end;
    end;
  end;
end;

function TPrinter.GetCanvas: TCanvas;
begin
  if FCanvas = nil then FCanvas := TPrinterCanvas.Create(Self);
  Result := FCanvas;
end;

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; export;
begin
  TStrings(Data).Add(StrPas(LogFont.lfFaceName));
  Result := 1;
end;

function TPrinter.GetFonts: TStrings;
var
  Proc: TFarProc;
begin
  if FFonts = nil then
  try
    SetState(psHandleIC);
    FFonts := TStringList.Create;
    Proc := MakeProcInstance(@EnumFontsProc, HInstance);
    try
      EnumFonts(DC, nil, Proc, Pointer(FFonts));
    finally
      FreeProcInstance(Proc);
    end;
  except
    FFonts.Free;
    FFonts := nil;
    raise;
  end;
  Result := FFonts;
end;

function TPrinter.GetHandle: HDC;
begin
  SetState(psHandleIC);
  Result := DC;
end;

function TPrinter.GetOrientation: TPrinterOrientation;
begin
  if FPrinterIndex = -1 then SetToDefaultPrinter;
  if DeviceMode = 0 then RaiseError(SInvalidPrinterOp);
  if PDevMode(Ptr(DeviceMode, 0))^.dmOrientation = DMORIENT_PORTRAIT then
    Result := poPortrait else
    Result := poLandscape;
end;

procedure TPrinter.SetOrientation(Value: TPrinterOrientation);
const
  Orientations: array [TPrinterOrientation] of Integer = (
    DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
begin
  CheckPrinting(False);
  if FPrinterIndex = -1 then SetToDefaultPrinter;
  if (DeviceMode = 0) or not Assigned(FExtDeviceMode) then
    RaiseError(SInvalidPrinterOp);
  SetState(psNoHandle);
  PDevMode(Ptr(DeviceMode, 0))^.dmOrientation := Orientations[Value];
end;

function TPrinter.GetPageHeight: Integer;
begin
  SetState(psHandleIC);
  Result := GetDeviceCaps(DC, VertRes);
end;

function TPrinter.GetPageWidth: Integer;
begin
  SetState(psHandleIC);
  Result := GetDeviceCaps(DC, HorzRes);
end;

function TPrinter.GetPrinterIndex: Integer;
begin
  if FPrinterIndex = -1 then SetToDefaultPrinter;
  Result := FPrinterIndex;
end;

procedure TPrinter.SetPrinterIndex(Value: Integer);
begin
  CheckPrinting(False);
  if Value = -1 then SetToDefaultPrinter
  else if (Value < 0) or (Value >= Printers.Count) then RaiseError(SPrinterIndexError);
  FPrinterIndex := Value;
  FreeFonts;
  SetState(psNoHandle);
end;

function TPrinter.GetPrinters: TStrings;
const
  DevicesSize = 4096;
var
  Devices: PChar;
  LineCur: PChar;
  DriverLine: array[0..79] of Char;
  DriverStr: array[0..79] of Char;
  Device, Driver, Port: PChar;
begin
  if FPrinters = nil then
  begin
    FPrinters := TStringList.Create;
    try
      GetMem(Devices, DevicesSize);
      try
        { Get a list of devices from WIN.INI.  Stored in the form of
          <device 1>#0<device 2>#0...<driver n>#0#0 }
        GetProfileString('devices', nil, '', Devices, DevicesSize);
        Device := Devices;
        while Device^ <> #0 do
        begin
          GetProfileString('devices', Device, '', DriverLine, SizeOf(DriverLine));
          { Get driver portion of DeviceLine }
          LineCur := DriverLine;
          Driver := FetchStr(LineCur);
          { Copy the port information from the line }
          { This code is complicated because the device line is of the form:
                <device name> = <driver name> , <port> [ , <port> ]
              where port (in []) can be repeated. }
          Port := FetchStr(LineCur);
          while Port^ <> #0 do
          begin
            FPrinters.AddObject(Format('%s on %s', [Device, Port]),
              TPrinterDevice.Create(Driver, Device, Port));
            Port := FetchStr(LineCur);
          end;
          Inc(Device, StrLen(Device) + 1);
        end;
      finally
        FreeMem(Devices, DevicesSize);
      end;
    except
      FPrinters.Free;
      FPrinters := nil;
      raise;
    end;
  end;
  Result := FPrinters;
end;

function TPrinter.GetTitle: string;
begin
  if FTitle = nil then FTitle := NewStr('');
  Result := FTitle^;
end;

procedure TPrinter.SetTitle(const Value: string);
var
  NewTitle: PString;
begin
  { The order is important for exceptions }
  NewTitle := NewStr(Value);
  DisposeStr(FTitle);
  FTitle := NewTitle;
end;

procedure TPrinter.SetToDefaultPrinter;
var
  I, J: Integer;
  DefaultPrinter: array[0..79] of Char;
  Cur: PChar;
  Driver, Device, Port: PChar;
begin
  GetProfileString('windows', 'device', '', DefaultPrinter,
    SizeOf(DefaultPrinter) - 1);
  Cur := DefaultPrinter;
  SetPrinter(FetchStr(Cur), FetchStr(Cur), FetchStr(Cur), 0);
end;

procedure TPrinter.FreePrinters;
var
  I: Integer;
begin
  if FPrinters <> nil then
  begin
    for I := 0 to FPrinters.Count - 1 do
      FPrinters.Objects[I].Free;
    FPrinters.Free;
    FPrinters := nil;
  end;
end;

procedure TPrinter.FreeFonts;
begin
  FFonts.Free;
  FFonts := nil;
end;

procedure DestroyGlobals; far;
begin
  Printer.Free;
end;

begin
  Printer := TPrinter.Create;
  AddExitProc(DestroyGlobals);
end.

