psjob.pas

GREATIS Print Suite Pro for Delphi (3-7,2005,2006,2007) and C++ Builder (3-6) Set of components for

(*  GREATIS PRINT SUITE                              *)
(*  unit version 1.85.093                            *)
(*  Copyright (C) 2001-2007 Greatis Software         *)
(*  http://www.greatis.com/delphicb/printsuite/      *)
(*  http://www.greatis.com/delphicb/printsuite/faq/  *)
(*  http://www.greatis.com/bteam.html                *)

unit PSJob;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Printers, Dialogs,
  Controls, Forms, PSCommon, Math, WinSpool;

type

  TMargins = class(TPersistent)
  private
    FLeft,FTop,FRight,FBottom: Double;
  published
    property Left: Double read FLeft write FLeft;
    property Top: Double read FTop write FTop;
    property Right: Double read FRight write FRight;
    property Bottom: Double read FBottom write FBottom;
  public
    procedure Assign(Source: TPersistent); override;
  end;

  TDrawTarget = (dtPrint,dtPreview,dtMetaPreview,dtExternal);

  TDrawArea = (daHeader,daPage,daFooter);
  TDrawAreas = set of TDrawArea;

  TAllowEvent = procedure (Sender: TObject; var Allow: Boolean) of object;

  TInitDrawEvent = procedure (Sender: TObject; TheCanvas: TCanvas;
    Target: TDrawTarget) of object;

  TDrawEvent = procedure (Sender: TObject; TheCanvas: TCanvas; PageIndex: Integer;
    TheRect: TRect; Area: TDrawArea; Target: TDrawTarget) of object;

  TPSProgressEvent = procedure (Sender: TObject; Pos,Min,Max: Integer) of object;

  TPageNotifyEvent = procedure (Sender: TObject; PageIndex: Integer) of object;

  TUnits = (unPixels,unPercents,unInches,unMillimeters);

  TDirection = (dirHorizontal,dirVertical);

  TPageMode = (pmDefault,pmCustom);

  TPageOrientation = (orDefault,orPortrait,orLandscape);

  TJobOptions = (joMargins,joHeader,joFooter);
  TJobOptionsSet = set of TJobOptions;

  TStretchMode = (smOriginalSize,sm1x1,smFit,smFitToWidth,smFitToHeight,smStretch,sm50,sm75,sm125,sm150,sm175,sm200,smCustom);

  TAlignHorizontal = (ahLeft,ahCenter,ahRight);

  TAlignVertical = (avTop,avCenter,avBottom);

  TPrintMode = (pmReverse,pmMultiDoc);
  TPrintModes = set of TPrintMode;

  TMarginsError = (meNone,meAutoFix,meMessageBox,meException);

  EPrintJobException = class(Exception);

  TCustomPrintJob = class(TComponent)
  private
    { Private declarations }
    FDrawTarget: TDrawTarget;
    FMustAbort: Boolean;
    FUpdateLocker: Integer;
    FUpdateJobsLocker: Integer;
    FUpdateControlsLocker: Integer;
    FDrawLocker: Integer;
    FControls: TList;
    FPrintJobs: TList;
    FOnCreate: TNotifyEvent;
    FOnDestroy: TNotifyEvent;
    FOnInitDraw: TInitDrawEvent;
    FOnDraw: TDrawEvent;
    FOnPrinterSetupChange: TNotifyEvent;
    FOnAllowPrint: TAllowEvent;
    FOnStartPrint: TNotifyEvent;
    FOnEndPrint: TNotifyEvent;
    FOnPrintProgress: TPSProgressEvent;
    FOnStartPrintPage: TPageNotifyEvent;
    FOnEndPrintPage: TPageNotifyEvent;
    FOnUpdate: TNotifyEvent;
    FMultiDoc: Boolean;
    FPageCount: Integer;
    FTitle: string;
    FMargins: TMargins;
    FMarginsUnits: TUnits;
    FMarginsError: TMarginsError;
    FHeader: Double;
    FHeaderUnits: TUnits;
    FFooter: Double;
    FFooterUnits: TUnits;
    FPageMode: TPageMode;
    FPageWidth: Double;
    FPageHeight: Double;
    FPageUnits: TUnits;
    FOrientation: TPageOrientation;
    FOptions: TJobOptionsSet;
    FRelativeCoords: Boolean;
    FDefaultDrawing: TDrawAreas;
    function GetAborted: Boolean;
    procedure SetPageCount(const Value: Integer);
    procedure SetMargins(const Value: TMargins);
    procedure SetMarginsUnits(const Value: TUnits);
    procedure SetMarginsError(const Value: TMarginsError);
    procedure CheckMargins(const Value: TMargins);
    procedure SetHeader(const Value: Double);
    procedure SetHeaderUnits(const Value: TUnits);
    procedure SetFooter(const Value: Double);
    procedure SetFooterUnits(const Value: TUnits);
    procedure SetPageMode(const Value: TPageMode);
    procedure SetPageWidth(const Value: Double);
    procedure SetPageHeight(const Value: Double);
    procedure SetPageUnits(const Value: TUnits);
    procedure SetOrientation(const Value: TPageOrientation);
    procedure SetOptions(const Value: TJobOptionsSet);
    procedure SetRelativeCoords(const Value: Boolean);
    procedure SetDefaultDrawing(const Value: TDrawAreas);
    function GetUpdateLocked: Boolean;
    function GetUpdateJobsLocked: Boolean;
    function GetUpdateControlsLocked: Boolean;
    function GetDrawLocked: Boolean;
    function GetPhysicalPageWidth: Integer;
    function GetPhysicalPageHeight: Integer;
    //procedure PageSetupDraw(Sender: TObject; Canvas: TCanvas; PageRect: TRect; var DoneDrawing: Boolean);
  protected
    { Protected declarations }
    procedure Loaded; override;
    procedure PhysicalOffset(var R: TRect);
    property DefaultDrawing: TDrawAreas read FDefaultDrawing write SetDefaultDrawing default [daHeader,daPage,daFooter];
    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
    property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
    property OnInitDraw: TInitDrawEvent read FOnInitDraw write FOnInitDraw;
    property OnDraw: TDrawEvent read FOnDraw write FOnDraw;
    property OnPrinterSetupChange: TNotifyEvent read FOnPrinterSetupChange write FOnPrinterSetupChange;
    property OnAllowPrint: TAllowEvent read FOnAllowPrint write FOnAllowPrint;
    property OnStartPrint: TNotifyEvent read FOnStartPrint write FOnStartPrint;
    property OnEndPrint: TNotifyEvent read FOnEndPrint write FOnEndPrint;
    property OnPrintProgress: TPSProgressEvent read FOnPrintProgress write FOnPrintProgress;
    property OnStartPrintPage: TPageNotifyEvent read FOnStartPrintPage write FOnStartPrintPage;
    property OnEndPrintPage: TPageNotifyEvent read FOnEndPrintPage write FOnEndPrintPage;
    property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ActiveInstance(PageIndex: Integer): TCustomPrintJob; virtual;
    procedure LockUpdate;
    procedure UnlockUpdate;
    procedure LockJobsUpdate;
    procedure UnlockJobsUpdate;
    procedure LockControlsUpdate;
    procedure UnlockControlsUpdate;
    procedure LockDraw;
    procedure UnlockDraw;
    procedure PaintTo(TheCanvas: TCanvas; PageIndex: Integer); virtual;
    procedure InitDraw(TheCanvas: TCanvas; Target: TDrawTarget); virtual;
    procedure Draw(TheCanvas: TCanvas; PageIndex: Integer; Target: TDrawTarget); virtual;
    procedure DrawArea(TheCanvas: TCanvas; PageIndex: Integer; TheRect: TRect; Area: TDrawArea; Target: TDrawTarget); virtual;
    procedure PrinterSetupChange; virtual;
    function AllowPrint: Boolean; virtual;
    procedure StartPrint; virtual;
    procedure EndPrint; virtual;
    procedure PrintProgress(CurPage,MinPage,MaxPage: Integer); virtual;
    procedure StartPrintPage(PageIndex: Integer); virtual;
    procedure EndPrintPage(PageIndex: Integer); virtual;
    procedure ForceNewPage(PageIndex: Integer); virtual;
    procedure PrintEx(StartPage,EndPage: Integer; PrintMode: TPrintModes);
    procedure Print; virtual;
    procedure PrintDialog; virtual;
    procedure PrinterSetupDialog; virtual;
    procedure Abort; virtual;
    function GetSheetRect: TRect; virtual;
    function GetPrintableRect: TRect; virtual;
    function GetMarginRect: TRect; virtual;
    function GetHeaderRect: TRect; virtual;
    function GetPageRect: TRect; virtual;
    function GetFooterRect: TRect; virtual;
    procedure ResetToDefaultPage; virtual;
    function PrinterOK: Boolean; virtual;
    procedure Update; virtual;
    procedure ApplyUpdates; virtual;
    procedure AddControlNotification(AControl: TControl);
    procedure DeleteControlNotification(AControl: TControl);
    procedure AddPrintJobNotification(APrintJob: TCustomPrintJob);
    procedure DeletePrintJobNotification(APrintJob: TCustomPrintJob);
    procedure DrawBitmap(TheCanvas: TCanvas; const TheRect: TRect; Bitmap: TBitmap; Target: TDrawTarget);
    procedure StretchBitmap(TheCanvas: TCanvas; const TheRect: TRect; Bitmap: TBitmap; StretchMode: TStretchMode; AlignHorizontal: TAlignHorizontal; AlignVertical: TAlignVertical; Target: TDrawTarget);
    procedure StretchGraphic(TheCanvas: TCanvas; const TheRect: TRect; Graphic: TGraphic; StretchMode: TStretchMode; Scale,PageIndex: Integer; AlignHorizontal: TAlignHorizontal; AlignVertical: TAlignVertical; Target: TDrawTarget);
    procedure DrawTabbedText(TheCanvas: TCanvas; X,Y: Integer; S: string);
    function DPIX: Integer;
    function DPIY: Integer;
    function InchToMm(Inches: Double): Double;
    function MmToInch(Millimeters: Double): Double;
    function InchToPix(Inches: Double; Direction: TDirection): Double;
    function MmToPix(Millimeters: Double; Direction: TDirection): Double;
    function PixToMm(Pixels: Double; Direction: TDirection): Double;
    function PixToInch(Pixels: Double; Direction: TDirection): Double;
    function ConvertUnits(Source: Double; FromUnits,ToUnits: TUnits; Dir: TDirection; FullRange: Double): Double;
    procedure ConvertMargins(M: TMargins; FromUnits,ToUnits: TUnits);
    property UpdateLocked: Boolean read GetUpdateLocked;
    property UpdateJobsLocked: Boolean read GetUpdateJobsLocked;
    property UpdateControlsLocked: Boolean read GetUpdateControlsLocked;
    property DrawLocked: Boolean read GetDrawLocked;
    property Aborted: Boolean read GetAborted;
    property MultiDoc: Boolean read FMultiDoc write FMultiDoc default False;
    property PageCount: Integer read FPageCount write SetPageCount default 1;
    property Title: string read FTitle write FTitle;
    property Margins: TMargins read FMargins write SetMargins;
    property MarginsUnits: TUnits read FMarginsUnits write SetMarginsUnits default unPixels;
    property MarginsError: TMarginsError read FMarginsError write SetMarginsError default meAutoFix;
    property Header: Double read FHeader write SetHeader;
    property HeaderUnits: TUnits read FHeaderUnits write SetHeaderUnits default unPixels;
    property Footer: Double read FFooter write SetFooter;
    property FooterUnits: TUnits read FFooterUnits write SetFooterUnits default unPixels;
    property PageMode: TPageMode read FPageMode write SetPageMode default pmDefault;
    property PageWidth: Double read FPageWidth write SetPageWidth;
    property PageHeight: Double read FPageHeight write SetPageHeight;
    property PhysicalPageWidth: Integer read GetPhysicalPageWidth;
    property PhysicalPageHeight: Integer read GetPhysicalPageHeight;
    property PageUnits: TUnits read FPageUnits write SetPageUnits default unPixels;
    property Orientation: TPageOrientation read FOrientation write SetOrientation default orDefault;
    property Options: TJobOptionsSet read FOptions write SetOptions default [];
    property RelativeCoords: Boolean read FRelativeCoords write SetRelativeCoords default False;
  end;

  TPrintJob = class(TCustomPrintJob)
  published
    property MultiDoc;
    property PageCount;
    property Title;
    property Margins;
    property MarginsUnits;
    property MarginsError;
    property Header;
    property HeaderUnits;
    property Footer;
    property FooterUnits;
    property PageMode;
    property PageWidth;
    property PageHeight;
    property PageUnits;
    property Orientation;
    property Options;
    property RelativeCoords;
    property OnCreate;
    property OnDestroy;
    property OnInitDraw;
    property OnDraw;
    property OnPrinterSetupChange;
    property OnAllowPrint;
    property OnStartPrint;
    property OnEndPrint;
    property OnPrintProgress;
    property OnStartPrintPage;
    property OnEndPrintPage;
    property OnUpdate;
  end;

procedure Register;

implementation

const
  MmInInch = 25.4;

{ TMargins }

procedure TMargins.Assign(Source: TPersistent);
begin
  {$IFDEF PSTRIAL}
  Left:=1;
  Top:=1;
  Right:=1;
  Bottom:=1;
  {$ELSE}
  Left:=TMargins(Source).Left;
  Top:=TMargins(Source).Top;
  Right:=TMargins(Source).Right;
  Bottom:=TMargins(Source).Bottom;
  {$ENDIF}
end;

{ TCustomPrintJob }

constructor TCustomPrintJob.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPageCount:=1;
  FMargins:=TMargins.Create;
  ResetToDefaultPage;
  FControls:=TList.Create;
  FPrintJobs:=TList.Create;
  try
    if Assigned(FOnCreate) then FOnCreate(Self);
  except
    raise;
  end;
  FMarginsError:=meAutoFix;
  FDefaultDrawing:=[daHeader,daPage,daFooter];
  {$IFDEF PSTRIAL}
  with FMargins do
  begin
    Left:=1;
    Top:=1;
    Right:=1;
    Bottom:=1;
  end;
  FMarginsUnits:=unInches;
  FFooter:=1;
  FFooterUnits:=unInches;
  FHeader:=1;
  FHeaderUnits:=unInches;
  FOptions:=[joMargins,joHeader,joFooter];
  {$ENDIF}
end;

destructor TCustomPrintJob.Destroy;
begin
  try
    if Assigned(FOnDestroy) then FOnDestroy(Self);
  except
  end;
  inherited Destroy;
  FPrintJobs.Free;
  FControls.Free;
  FControls:=nil;
  FMargins.Free;
end;

function TCustomPrintJob.ActiveInstance(PageIndex: Integer): TCustomPrintJob;
begin
  Result:=Self;
end;

procedure TCustomPrintJob.LockUpdate;
begin
  Inc(FUpdateLocker);
end;

procedure TCustomPrintJob.UnlockUpdate;
begin
  if FUpdateLocker>0 then Dec(FUpdateLocker);
end;

procedure TCustomPrintJob.LockJobsUpdate;
begin
  Inc(FUpdateJobsLocker);
end;

procedure TCustomPrintJob.UnlockJobsUpdate;
begin
  if FUpdateJobsLocker>0 then Dec(FUpdateJobsLocker);
end;

procedure TCustomPrintJob.LockControlsUpdate;
begin
  Inc(FUpdateControlsLocker);
end;

procedure TCustomPrintJob.UnlockControlsUpdate;
begin
  if FUpdateControlsLocker>0 then Dec(FUpdateControlsLocker);
end;

procedure TCustomPrintJob.LockDraw;
begin
  Inc(FDrawLocker);
end;

procedure TCustomPrintJob.UnlockDraw;
begin
  if FDrawLocker>0 then Dec(FDrawLocker);
end;

function TCustomPrintJob.GetSheetRect: TRect;
begin
  if PrinterOK then
    with Printer do
    begin
      Result:=Rect(0,0,
        Round(ConvertUnits(FPageWidth,FPageUnits,unPixels,dirHorizontal,PhysicalPageWidth)),
        Round(ConvertUnits(FPageHeight,FPageUnits,unPixels,dirVertical,PhysicalPageHeight)));
    end
  else
  begin
    FPageHeight:=3000;
    FPageWidth:=2000;
    Result:=Rect(0,0,Round(FPageWidth),Round(FPageHeight));
  end;
end;

function TCustomPrintJob.GetPrintableRect: TRect;
begin
  if PrinterOK then
    with Printer do
      Result:=Rect(0,0,GetDeviceCaps(Handle,HORZRES),GetDeviceCaps(Handle,VERTRES))
  else Result:=GetSheetRect;
end;

function TCustomPrintJob.GetMarginRect: TRect;
var
  IMargins: TMargins;
begin
  Result:=GetSheetRect;
  if FDrawTarget=dtPrint then PhysicalOffset(Result);
  if joMargins in FOptions then
  begin
    IMargins:=TMargins.Create;
    try
      IMargins.Assign(Margins);
      ConvertMargins(IMargins,FMarginsUnits,unPixels);
      with IMargins do
      begin
        Result.Left:=Round(Result.Left+Left);
        Result.Top:=Round(Result.Top+Top);
        Result.Right:=Round(Result.Right-Right);
        Result.Bottom:=Round(Result.Bottom-Bottom);
      end;
    finally
      IMargins.Free;
    end;
  end;
end;

function TCustomPrintJob.GetHeaderRect: TRect;
begin
  if joHeader in FOptions then
  begin
    Result:=GetMarginRect;
    with Result do
      Bottom:=Top+Round(ConvertUnits(FHeader,FHeaderUnits,unPixels,dirVertical,Bottom-Top));
  end
  else Result:=Rect(0,0,0,0);
end;

function TCustomPrintJob.GetPageRect: TRect;
var
  H: Integer;
begin
  Result:=GetMarginRect;
  with Result do
  begin
    H:=Bottom-Top;
    if joHeader in FOptions then Inc(Top,Round(ConvertUnits(FHeader,FHeaderUnits,unPixels,dirVertical,H)));
    if joFooter in FOptions then Dec(Bottom,Round(ConvertUnits(FFooter,FFooterUnits,unPixels,dirVertical,H)));
  end;
end;

function TCustomPrintJob.GetFooterRect: TRect;
begin