{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1995-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.Printers platform;

{$R-,T-,X+,H+}

interface

uses WinUtils, Windows, SysUtils, Classes, Graphics, Forms,
  System.Runtime.InteropServices;

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);
  TPrinterCapability = (pcCopies, pcOrientation, pcCollation);
  TPrinterCapabilities = set of TPrinterCapability;

  TPrinter = class(TObject)
  private
    FCanvas: TCanvas;
    FPageNumber: Integer;
    FPrinters: TStrings;
    FPrinterIndex: Integer;
    FTitle: string;
    FPrinting: Boolean;
    FAborted: Boolean;
    FCapabilities: TPrinterCapabilities;
    FFonts: TStrings;
    State: TPrinterState;
    DC: HDC;
//    DevMode: TDeviceMode;
    DeviceMode: IntPtr; 
    FPrinterHandle: THandle;
                                         
    function EnumFontsProc([in] var LogFont: TLogFont; [in] var TextMetric: TTextMetric;
      FontType: DWORD; Data: LPARAM): Integer;
    function GetPrinterInfo4(FPrinters: TStrings; Offset: Integer; Mem: IntPtr): Integer;
    function GetPrinterInfo5(FPrinters: TStrings; Offset: Integer; Mem: IntPtr): Integer;
    procedure UpdateDeviceMode(ADeviceMode: IntPtr);
    procedure SetState(Value: TPrinterState);
    function GetCanvas: TCanvas;
    function GetNumCopies: Integer;
    function GetFonts: TStrings;
    function GetHandle: HDC;
    function GetOrientation: TPrinterOrientation;
    function GetPageHeight: Integer;
    function GetPageWidth: Integer;
    function GetPrinterIndex: Integer;
    procedure SetPrinterCapabilities(Value: Integer);
    procedure SetPrinterIndex(Value: Integer);
    function GetPrinters: TStrings;
    procedure SetNumCopies(Value: Integer);
    procedure SetOrientation(Value: TPrinterOrientation);
    procedure SetToDefaultPrinter;
    procedure CheckPrinting(Value: Boolean);
    procedure FreePrinters;
    procedure FreeFonts;
  strict protected
    procedure Finalize; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Abort;
    procedure BeginDoc;
    procedure EndDoc;
    procedure NewPage;
    procedure GetPrinter(var ADevice, ADriver, APort: string; var ADeviceMode: IntPtr);
    procedure SetPrinter(ADevice, ADriver, APort: string; ADeviceMode: IntPtr);
    procedure Refresh;
    property Aborted: Boolean read FAborted;
    property Canvas: TCanvas read GetCanvas;
    property Capabilities: TPrinterCapabilities read FCapabilities;
    property Copies: Integer read GetNumCopies write SetNumCopies;
    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 FTitle write FTitle;
  end;

{ Printer function - Replaces the Printer global variable of previous versions,
  to improve smart linking (reduce exe size by 2.5k in projects that don't use
  the printer).  Code which assigned to the Printer global variable
  must call SetPrinter instead.  SetPrinter returns current printer object
  and makes the new printer object the current printer.  It is the caller's
  responsibility to free the old printer, if appropriate.  (This allows
  toggling between different printer objects without destroying configuration
  settings.) }

function Printer: TPrinter;
function SetPrinter(NewPrinter: TPrinter): 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
  System.Text, System.IO, System.Drawing.Printing, WinSpool, Consts;

var
  FPrinter: TPrinter = nil;

function FetchStr(Str: string; CurPos: Integer; out OutStr: string): Integer;
var
  Len: Integer;
begin
  Len := Length(Str);
  Result := 0;
  if (CurPos <= 0) or (CurPos > Len) then
    Exit;
  while (CurPos <= Len) and (Str[CurPos] = ' ') do
    Inc(CurPos);
  Result := CurPos;
  while (Result <= Len) and (Str[Result] <> ',') do
    Inc(Result);
  OutStr := Copy(Str, CurPos, Result - CurPos);
  Inc(Result);
end;

procedure RaiseError(const Msg: string);
begin
  raise EPrinter.Create(Msg);
end;

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

{ AssignPrn support }
type
  PrnRec = record
    Cur: TPoint;
    Finish: TPoint;         { End of the printable area }
    Height: Integer;       { Height of the current line }
  end;

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

{ 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(FPrinter.Canvas.Handle, Metrics);
    Result := Metrics.tmHeight;
  end;

begin
  with Prn do
  begin
    Cur.X := 0;
    if Height = 0 then
      Inc(Cur.Y, CharHeight) else
      Inc(Cur.Y, Height);
    if Cur.Y > (Finish.Y - (Height * 2)) then NewPage(Prn);
    Height := 0;
  end;
end;

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

      while (L > 0) and (Extent.cX + Cur.X > Finish.X) do
      begin
        Dec(L);
        GetTextExtentPoint(Handle, Text, L, Extent);
      end;

      if Extent.cY > Height then Height := Extent.cY + 2;
      Windows.TextOut(Handle, Cur.X, Cur.Y, Text, L);
      Dec(Len, L);
      Text := Copy(Text, L + 1, Len);
      if Len > 0 then NewLine(Prn)
      else Inc(Cur.X, Extent.cX);
    end;
  end;
end;

{ Print a string to the printer handling special characters. }
procedure PrnString(var Prn: PrnRec; Text: string; Len: Integer);
var
  L: Integer;
  TabWidth: Word;

  procedure Flush;
  begin
    if L <> 0 then PrnOutStr(Prn, Text, L);
    Text := Copy(Text, L + 2, Len);
    Dec(Len, L + 1);
    L := 0;
  end;

  function AvgCharWidth: Word;
  var
    Metrics: TTextMetric;
  begin
    GetTextMetrics(FPrinter.Canvas.Handle, Metrics);
    Result := Metrics.tmAveCharWidth;
  end;

begin
  L := 0;
  with Prn do
  begin
    while L < Len do
    begin
      case Text[L + 1] 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;

type
  TPrinterTextFactory = class(TObject, ITextDeviceFactory)
    function Open(t: Text; Mode: Word): Integer;
    function Close(t: Text): Integer;
  end;

  TPrinterWriter = class(System.IO.TextWriter)
  private
    FPrnRec: PrnRec;
  public
    constructor Create;
    procedure Close; override;
    function get_Encoding: System.Text.Encoding; override;
    procedure Write(Value: Char); override;
    procedure Write(buffer: array of Char); override;
    procedure Write(buffer: array of Char; index: Integer; count: Integer); override;
    procedure Write(Value: string); override;
    procedure WriteLine; override;
  end;

function TPrinterTextFactory.Open(t: Text; Mode: Word): Integer;
begin
  if Mode <> fmOutput then
  begin
    Result := 102;
    Exit;
  end;
  t.Reader := nil;  // cant read
  t.Writer := TPrinterWriter.Create;
  t.Mode := fmOutput;
  Result := 0;
end;

function TPrinterTextFactory.Close(t: Text): Integer;
begin
//  if t.Writer <> nil then
//    (t.Writer as System.IO.StreamWriter).BaseStream.Close;
  t.Reader := nil;
  t.Writer := nil;
  t.Mode := fmClosed;
  Result := 0;
end;

constructor TPrinterWriter.Create;
begin
  inherited;
  FPrinter.BeginDoc;
  FPrnRec.Cur.X := 0;
  FPrnRec.Cur.Y := 0;
  FPrnRec.Finish.X := FPrinter.PageWidth;
  FPrnRec.Finish.Y := FPrinter.PageHeight;
  FPrnRec.Height := 0;
end;

procedure TPrinterWriter.Close;
begin
    FPrinter.EndDoc;
end;

function TPrinterWriter.get_Encoding: System.Text.Encoding;
begin
  Result := System.Text.Encoding.ASCII;
end;

procedure TPrinterWriter.Write(Value: Char);
begin
  PrnString(FPrnRec, Value, 1);
end;

procedure TPrinterWriter.Write(buffer: array of Char);
var
  S: string;
begin
  S := System.String.Create(buffer);
  PrnString(FPrnRec, S, Length(S));
end;

procedure TPrinterWriter.Write(buffer: array of Char; index: Integer; count: Integer);
var
  S: string;
begin
  S := System.String.Create(buffer, index, count);
  PrnString(FPrnRec, S, count);
end;

procedure TPrinterWriter.Write(Value: string);
begin
  PrnString(FPrnRec, Value, Length(Value));
end;

procedure TPrinterWriter.WriteLine;
begin
  Borland.Vcl.Printers.NewLine(FPrnRec);
end;

procedure AssignPrn(var F: Text);
begin
  if not Assigned(F) then
    F := Text.Create;
  F.Mode := fmClosed;
  F.Flags := 0;
  F.Factory := TPrinterTextFactory.Create;
  F.Reader := nil;
  F.Writer := nil;
  F.Filename := '';
end;


{ TPrinterDevice }

type
  TPrinterDevice = class
    Driver, Device, Port: String;
    constructor Create(ADriver, ADevice, APort: string);
    function IsEqual(ADriver, ADevice, APort: string): Boolean;
  end;

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

function TPrinterDevice.IsEqual(ADriver, ADevice, APort: string): Boolean;
begin
  Result := (Device = ADevice) and ((Port = '') or (Port = APort));
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;
  UpdateFont;
end;

procedure TPrinterCanvas.UpdateFont;
var
  FontSize: Integer;
begin
  if GetDeviceCaps(Printer.DC, LOGPIXELSY) <> Font.PixelsPerInch then
  begin
    FontSize := Font.Size;
    Font.PixelsPerInch := GetDeviceCaps(Printer.DC, LOGPIXELSY);
    Font.Size := FontSize;
  end;
end;

{ TPrinter }

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

destructor TPrinter.Destroy;
begin
  if Printing then EndDoc;
  SetState(psNoHandle);
  FreePrinters;
  FreeFonts;
  FreeAndNil(FCanvas);
  if FPrinterHandle <> 0 then
  begin
    ClosePrinter(FPrinterHandle);
    FPrinterHandle := 0;
  end;
  if DeviceMode <> nil then
  begin
    Marshal.DestroyStructure(DeviceMode, TypeOf(TDeviceMode));
    DeviceMode := nil;
  end;
  System.GC.SuppressFinalize(self);
  inherited Destroy;
end;

procedure TPrinter.Finalize;
begin
  if Printing then EndDoc;
  if DC <> 0 then
  begin
    SelectObject(DC, GetStockObject(BLACK_PEN));
    SelectObject(DC, GetStockObject(HOLLOW_BRUSH));
    SelectObject(DC, GetStockObject(SYSTEM_FONT));
    DeleteDC(DC);
    DC := 0;
  end;
  State := psNoHandle;
  if FPrinterHandle <> 0 then
  begin
    ClosePrinter(FPrinterHandle);
    FPrinterHandle := 0;
  end;
  if DeviceMode <> nil then
  begin
    Marshal.DestroyStructure(DeviceMode, TypeOf(TDeviceMode));
    DeviceMode := nil;
  end;
  inherited;
end;

procedure TPrinter.SetState(Value: TPrinterState);
var
  DevMode: TDeviceMode;
  Temp: IntPtr;
  GetIC: Boolean;
  EndOfStr: Integer;
begin
  if Value <> State then
  begin
    GetIC := True;
    case Value of
      psNoHandle:
        begin
          CheckPrinting(False);
          if Assigned(FCanvas) then FCanvas.Handle := 0;
          DeleteDC(DC);
          DC := 0;
          State := psNoHandle;
          Exit;
        end;
      psHandleIC:
        if State = psHandleDC then
          Exit;
      psHandleDC:
        begin
          if FCanvas <> nil then FCanvas.Handle := 0;
          if DC <> 0 then DeleteDC(DC);
          GetIC := False;
        end;
    end;
    with TPrinterDevice(Printers.Objects[PrinterIndex]) do
    begin
      SetLength(Port, 256);
      Temp := Marshal.StringToHGlobalAuto(Port);
      try
        if DeviceMode = nil then
          if GetIC then
            DC := CreateIC(Driver, Device, Temp, nil)
          else
            DC := CreateDC(Driver, Device, Temp, nil)
        else
        begin
          DevMode := TDeviceMode(Marshal.PtrToStructure(DeviceMode, TypeOf(TDeviceMode)));
          if GetIC then
            DC := CreateIC(Driver, Device, Temp, DevMode)
          else
            DC := CreateDC(Driver, Device, Temp, DevMode);
        end;
        Port := Marshal.PtrToStringAuto(Temp);
        EndOfStr := Pos(#0, Port);
        if EndOfStr >= 1 then
          SetLength(Port, EndOfStr - 1)
        else
          SetLength(Port, 0);
      finally
        Marshal.FreeHGlobal(Temp);
      end;
      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;
  EndDoc;
  FAborted := True;
end;

procedure TPrinter.BeginDoc;
var
  DocInfo: TDocInfo;
begin
  CheckPrinting(False);
  SetState(psHandleDC);
  Canvas.Refresh;
  TPrinterCanvas(Canvas).UpdateFont;
  FPrinting := True;
  FAborted := False;
  FPageNumber := 1;

  with DocInfo do
  begin
    cbSize := SizeOf(DocInfo);
    lpszDocName := Title;
    lpszOutput := '';
    lpszDatatype := '';
    fwType := 0;
  end;
  SetAbortProc(DC, AbortProc);
  StartDoc(DC, DocInfo);
  StartPage(DC);
end;

procedure TPrinter.EndDoc;
begin
  CheckPrinting(True);
  EndPage(DC);
  if not Aborted then Windows.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(var ADevice, ADriver, APort: string; var ADeviceMode: IntPtr);
begin
  with TPrinterDevice(Printers.Objects[PrinterIndex]) do
  begin
    ADevice := Device;
    ADriver := Driver;
    APort := Port;
  end;
  ADeviceMode := DeviceMode;
end;

procedure TPrinter.SetPrinterCapabilities(Value: Integer);
begin
  FCapabilities := [];
  if (Value and DM_ORIENTATION) <> 0 then
    Include(FCapabilities, pcOrientation);
  if (Value and DM_COPIES) <> 0 then
    Include(FCapabilities, pcCopies);
  if (Value and DM_COLLATE) <> 0 then
    Include(FCapabilities, pcCollation);
end;

procedure TPrinter.UpdateDeviceMode(ADeviceMode: IntPtr);
begin
 if DeviceMode <> nil then
    Marshal.DestroyStructure(DeviceMode, TypeOf(TDeviceMode));
 DeviceMode := ADeviceMode;
end;

procedure TPrinter.SetPrinter(ADevice, ADriver, APort: string; ADeviceMode: IntPtr);
var
  I, J: Integer;
  DevMode: TDeviceMode;
begin
  CheckPrinting(False);
  if ADeviceMode <> DeviceMode then
    UpdateDeviceMode(ADeviceMode);
  if DeviceMode <> nil then
  begin
    DevMode := TDeviceMode(Marshal.PtrToStructure(DeviceMode, TypeOf(TDeviceMode)));
    SetPrinterCapabilities(DevMode.dmFields);
  end;
  FreeFonts;
  if FPrinterHandle <> 0 then
  begin
    ClosePrinter(FPrinterHandle);
    FPrinterHandle := 0;
  end;
  SetState(psNoHandle);
  J := -1;
  with Printers do   // <- this rebuilds the FPrinters list
    for I := 0 to Count - 1 do
    begin
      if TPrinterDevice(Objects[I]).IsEqual(ADriver, ADevice, APort) then
      begin
        TPrinterDevice(Objects[I]).Port := APort;
        J := I;
        Break;
      end;
    end;
  if J = -1 then
  begin
    J := FPrinters.Count;
    FPrinters.AddObject(Format(SDeviceOnPort, [ADevice, APort]),
      TPrinterDevice.Create(ADriver, ADevice, APort));
  end;
  FPrinterIndex := J;
  if OpenPrinter(ADevice, FPrinterHandle, nil) then
  begin
    if DeviceMode = nil then  // alloc new device mode block if one was not passed in
    begin
      DeviceMode := Marshal.AllocHGlobal(
        DocumentProperties(0, FPrinterHandle, ADevice, DeviceMode, DeviceMode, 0));
      if DeviceMode <> nil then
        if DocumentProperties(0, FPrinterHandle, ADevice, DeviceMode, DeviceMode,
          DM_OUT_BUFFER) < 0 then
          UpdateDeviceMode(nil)
    end;
    if DeviceMode <> nil then
      SetPrinterCapabilities(DevMode.dmFields);
  end;
end;

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

function TPrinter.EnumFontsProc([in] var LogFont: TLogFont; [in] var TextMetric: TTextMetric;
  FontType: DWORD; Data: LParam): Integer;
begin
  FFonts.Add(LogFont.lfFaceName);
  Result := 1;
end;

function TPrinter.GetFonts: TStrings;
begin
  if FFonts = nil then
  try
    SetState(psHandleIC);
    FFonts := TStringList.Create;
    EnumFonts(DC, nil, EnumFontsProc, 0);
  except
    FreeAndNil(FFonts);
    raise;
  end;
  Result := FFonts;
end;

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

function TPrinter.GetNumCopies: Integer;
var
  DMode: TDeviceMode;
begin
  GetPrinterIndex;
  if DeviceMode = nil then
    RaiseError(SInvalidPrinterOp);
  DMode := TDeviceMode(Marshal.PtrToStructure(DeviceMode, TypeOf(TDeviceMode)));
  Result := DMode.dmCopies;
end;

procedure TPrinter.SetNumCopies(Value: Integer);
var
  DMode: TDeviceMode;
begin
  CheckPrinting(False);
  GetPrinterIndex;
  if DeviceMode = nil then
    RaiseError(SInvalidPrinterOp);
  SetState(psNoHandle);
  DMode := TDeviceMode(Marshal.PtrToStructure(DeviceMode, TypeOf(TDeviceMode)));
  DMode.dmCopies := Value;
  Marshal.StructureToPtr(TObject(DMode), DeviceMode, True);
end;

function TPrinter.GetOrientation: TPrinterOrientation;
var
  Orientation: SmallInt;
  DMode: TDeviceMode;
begin
  GetPrinterIndex;
  if DeviceMode = nil then
    RaiseError(SInvalidPrinterOp);
  DMode := TDeviceMode(Marshal.PtrToStructure(DeviceMode, TypeOf(TDeviceMode)));
  Orientation := DMode.dmOrientation;
  if Orientation = DMORIENT_PORTRAIT then
    Result := poPortrait
  else
    Result := poLandscape;
end;

const
  Orientations: array [TPrinterOrientation] of Integer = (
    DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
procedure TPrinter.SetOrientation(Value: TPrinterOrientation);
var
  DMode: TDeviceMode;
begin
  CheckPrinting(False);
  GetPrinterIndex;
  if DeviceMode = nil then
    RaiseError(SInvalidPrinterOp);
  SetState(psNoHandle);
  DMode := TDeviceMode(Marshal.PtrToStructure(DeviceMode, TypeOf(TDeviceMode)));
  DMode.dmOrientation := Orientations[Value];
  Marshal.StructureToPtr(TObject(DMode), DeviceMode, True);
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) or (PrinterIndex = -1) then SetToDefaultPrinter
  else if (Value < 0) or (Value >= Printers.Count) then RaiseError(SPrinterIndexError);
  FPrinterIndex := Value;
  FreeFonts;
  SetState(psNoHandle);
end;

function TPrinter.GetPrinterInfo4(FPrinters: TStrings; Offset: Integer; Mem: IntPtr): Integer;
var
  Ptr: IntPtr;
  Prnter: string;
begin
  Ptr := Marshal.ReadIntPtr(Mem, Offset); // printer name is first member
  Prnter := Marshal.PtrToStringAuto(Ptr);
  FPrinters.AddObject(Prnter, TPrinterDevice.Create('', Prnter, ''));
  Result := Offset + Marshal.SizeOf(TypeOf(TPrinterInfo4));
end;

function TPrinter.GetPrinterInfo5(FPrinters: TStrings; Offset: Integer; Mem: IntPtr): Integer;
var
  Ptr: IntPtr;
  LineCur, Port, Prnter: string;
  Index : Integer;
begin
  Ptr := Marshal.ReadIntPtr(Mem, Offset); // pPrinterName
  Prnter := Marshal.PtrToStringAuto(Ptr);
  Ptr := Marshal.ReadIntPtr(Mem, Offset + sizeOf(IntPtr)); //pPortName
  LineCur := Marshal.PtrToStringAuto(Ptr);
  Index := FetchStr(LineCur, 1, Port);
  while Index <> 0 do
  begin
    FPrinters.AddObject(Format(SDeviceOnPort, [Prnter, Port]),
      TPrinterDevice.Create('', Prnter, Port));
    Index := FetchStr(LineCur, Index, Port);
  end;
  Result := Offset + Marshal.SizeOf(TypeOf(TPrinterInfo5));
end;

function TPrinter.GetPrinters: TStrings;
var
  BufPtr: IntPtr;
  Offset: Integer;
  Flags, Count, NumInfo: DWORD;
  I: Integer;
  Level: Byte;
begin
  if FPrinters = nil then
  begin
    FPrinters := TStringList.Create;
    Result := FPrinters;
    try
      if Win32Platform = VER_PLATFORM_WIN32_NT then
      begin
        Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL;
        Level := 4;
      end
      else
      begin
        Flags := PRINTER_ENUM_LOCAL;
        Level := 5;
      end;
      Count := 0;
      EnumPrinters(Flags, nil, Level, nil, 0, Count, NumInfo);
      if Count = 0 then Exit;
      BufPtr := Marshal.AllocHGlobal(Count);
      try
        if not EnumPrinters(Flags, nil, Level, BufPtr, Count, Count, NumInfo) then
          Exit;
        Offset := 0;
        for I := 0 to NumInfo - 1 do
        begin
          if Level = 4 then
            Offset := GetPrinterInfo4(FPrinters, Offset, BufPtr)
          else
            Offset := GetPrinterInfo5(FPrinters, Offset, BufPtr);
        end;
      finally
        Marshal.FreeHGlobal(BufPtr);
      end;
    except
      FPrinters.Free;
      FPrinters := nil;
      raise;
    end;
  end;
  Result := FPrinters;
end;

procedure TPrinter.SetToDefaultPrinter;
var
  I: Integer;
  ByteCnt, StructCnt: DWORD;
  Device: string;
  PrinterInfo, NamePtr: IntPtr;
  PD: System.Drawing.Printing.PrintDocument;
begin
  ByteCnt := 0;
  StructCnt := 0;
  if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, ByteCnt,
    StructCnt) and (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
  begin
    // With no printers installed, Win95/98 fails above with "Invalid filename".
    // NT succeeds and returns a StructCnt of zero.
    if GetLastError = ERROR_INVALID_NAME then
      RaiseError(SNoDefaultPrinter)
    else
      RaiseLastWin32Error;
  end;
  PrinterInfo := Marshal.AllocHGlobal(ByteCnt);
  try
    EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt,
      StructCnt);
    if StructCnt > 0 then
    begin
      NamePtr := Marshal.ReadIntPtr(PrinterInfo, 0); // pPrinterName
      Device := Marshal.PtrToStringAuto(NamePtr);
    end;
  finally
    Marshal.FreeHGlobal(PrinterInfo);
  end;
  if StructCnt <= 0 then {EnumPrinters didnt work, try using CLR}
  begin
    PD := System.Drawing.Printing.PrintDocument.Create;
    Device := PD.DefaultPageSettings.PrinterSettings.PrinterName;
  end;
  with Printers do
    for I := 0 to Count-1 do
    begin
      if WideSameText(TPrinterDevice(Objects[I]).Device, Device) then
      begin
        with TPrinterDevice(Objects[I]) do
          SetPrinter(Device, Driver, Port, nil);
        Exit;
      end;
    end;
  RaiseError(SNoDefaultPrinter);
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;
    FreeAndNil(FPrinters);
  end;
end;

procedure TPrinter.FreeFonts;
begin
  FreeAndNil(FFonts);
end;

function Printer: TPrinter;
begin
  if FPrinter = nil then
    FPrinter := TPrinter.Create;
  Result := FPrinter;
end;

function SetPrinter(NewPrinter: TPrinter): TPrinter;
begin
  Result := FPrinter;
  FPrinter := NewPrinter;
end;

procedure TPrinter.Refresh;
begin
  FreeFonts;
  FreePrinters;
end;

initialization

finalization
  FPrinter.Free;
end.
