Chip 1999 March/Chip_1999-03_cd.bin/zkuste/delphi/D12/ALREP.ZIP/Alrep.pas

Pascal/Delphi Source File | 1998-10-05 | 40KB | 1,537 lines

unit Alrep;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls, Printers, DrawMeta;

type
  {tOrientation = (poPortrait,poLandscape);}
  tPapersize   = (alr_A4,alr_A5);
type
  tAbschnittTyp = (alr_Titel,alr_Seitenkopf,
                   alr_SpaltenKopf,alr_Spalte,alr_Spaltenfuss,
                   alr_Seitenfuss,alr_Ende, alr_NewPage,
                   alr_GruppenKopf, alr_GruppenFuss);
type
  tAlSysDataType = (alr_Time,alr_Date,alr_DateTime,
                    alr_PageNum,alr_Zaehler,alr_Anzahl);

type
  tAlControl = class(tCustomLabel)
  private
    FValues : tStringList;
    dindex  : integer;
  protected
    procedure Print (X,Y,W,H:integer); virtual;
    procedure PrintOut (X,Y,W,H:integer; const s:string); virtual;
    procedure ResetData; virtual;
    procedure ClearData; virtual;
    function  Skip:boolean; virtual;
  public
    constructor Create (AOwner:tComponent); override;
    destructor  destroy; override;
  published
    { ver÷ffentlichen geerbte Properties }
    property visible;
  end;

type
  TAlFeld = class(tAlControl)
  private
  protected
    procedure Print (X,Y,W,H:integer); override;
    function  GetValue:string;
    function  GetNextValue:string;
  public
    constructor Create (AOwner:tComponent); override;
    property    value:string read GetValue;
    property    NextValue:string read GetNextValue;
  published
    { ver÷ffentlichen geerbte Properties }
    property Caption;
    property Alignment;
    property AutoSize default true;
    property Transparent;
    property WordWrap;
    property Color;
    property Font;
    property ParentFont;
    property Enabled;
  end;

type
  TAlShape = class(tAlControl)
  private
    FBrush : tBrush;
    FPen   : tPen;
    FShape : tShapeType;
  protected
    procedure SetBrush(value:tBrush);
    procedure SetPen (value:tPen);
    procedure SetShape (value:tShapeType);
    procedure Paint; override;
    procedure Print (X,Y,W,H:integer); override;
  public
    constructor Create (AOwner:tComponent); override;
    destructor  destroy; override;
  published
    procedure StyleChanged (Sender:tObject);
    { ver÷ffentlichen geerbte Properties }
    property Height default 65;
    property Width  default 65;
    { neue Properties }
    property Brush:tBrush read FBrush write SetBrush;
    property Pen:tPen read FPen write SetPen;
    property Shape:tShapeType read FShape write SetShape;
  end;

type
  tAlImage = class(tAlControl)
  private
    FPicture  : tPicture;
    FStretch  : boolean;
    FCenter   : boolean;
    FAutosize : boolean;
    aPen      : tPen;
  protected
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure Paint; override;
    procedure SetCenter (value:boolean);
    procedure SetStretch (value:boolean);
    procedure SetPicture (value:tPicture);
    procedure SetAutosize (value:boolean);
    procedure Print (X,Y,W,H:integer); override;
  public
    constructor create (AOwner:tComponent); override;
    destructor  destroy; override;
  published
    procedure PicChanged (Sender:tObject);
    property Autosize read FAutosize write SetAutosize default false;
    property Height   default 100;
    property Width    default 100;
    property Center:boolean read FCenter write SetCenter default true;
    property Stretch:boolean read FStretch write SetStretch default true;
    property Picture:tPicture read FPicture write SetPicture;
  end;

type
  TAlSysFeld = class(tAlControl)
  private
    FSysDataType : tAlSysDataType;
  protected
    Procedure SetSysDataType (value:tAlSysDataType);
    function  Skip:boolean; override;
    procedure Print (X,Y,W,H:integer); override;
  public
    { Public-Deklarationen }
    constructor Create (AOwner:TComponent); override;
  published
    { ver÷ffentlichen geerbte Properties }
    property Alignment;
    property AutoSize;
    property Transparent;
    property WordWrap;
    property Color;
    property Font;
    property ParentFont;
    property Enabled;
    { neue Properties }
    property DataType:tAlSysDataType read FSysDataType write SetSysDataType;
  end;

type
  tAlAbschnitt = class;
// type omitted for forward declaration
  TAlDetailLink = class(tComponent)
  private
    lastVal      : string;
    FGruppenKopf : tAlAbschnitt;
    FGruppenFuss : tAlAbschnitt;
    FDetailBand  : tAlAbschnitt;
    FDataSource  : tAlFeld;
    procedure SetDetailBand (value:tAlAbschnitt);
  protected
    Function CheckChanged (check_for:boolean):boolean;
  public
  published
    property GruppenKopf:tAlAbschnitt read FGruppenKopf write FGruppenKopf;
    property GruppenFuss:tAlAbschnitt read FGruppenFuss write FGruppenFuss;
    property GruppenAbschnitt:tAlAbschnitt read FDetailBand write SetDetailBand;
    property DataSource :tAlFeld      read FDataSource  write FDataSource;
  end;
// type omitted for forward declaration
  TAlAbschnitt = class(tCustomPanel)
  private
    FAbschnittTyp : tAbschnittTyp;
    FAltColor     : boolean;
    alt           : boolean; // alternate the background color if not white
    FDetailLink   : tAlDetailLink;
    procedure SetAbschnittTyp (value:tAbschnittTyp);
  protected
    procedure Paint; override;
  public
    { Public-Deklarationen }
    constructor Create (AOwner:TComponent); override;
  published
    { ver÷ffentlichen geerbte Properties }
    property Align;
    property Color;
    property Font;
    property ParentFont;
    property Enabled;
    { neue Properties }
    property AbschnittTyp:tAbschnittTyp read FAbschnittTyp write SetAbschnittTyp;
    property AltColor:boolean read FAltColor write FAltColor;
  end;

type
  tPages = class (tList)
     function GetPage(index:integer):tGraphic;
  public
     procedure Clear;
     property Page[index:integer]:tGraphic read GetPage;
  end;

type
  TAlReport = class(tComponent)
  private
    { Private-Deklarationen }
    RptHeaders   : tList;
    PgeHeaders   : tList;
    DtlHeaders   : tList;
    Details      : tList;
    DtlFooters   : tList;
    PgeFooters   : tList;
    RptFooters   : tList;
    YPos         : LongInt;
    MaxYPos      : LongInt;
    FirstPage    : boolean;

    { Property Functions }
    FOrientation : tPrinterOrientation;
    FPapersize   : tPapersize;
    FLeftMargin  : integer;
    procedure SetOrientation (value:tPrinterOrientation);
    procedure SetPapersize   (value:tPapersize);
    procedure SetLeftMargin  (value:integer);
    procedure UpdateScrollBars;
    procedure PrintDtlHeader(nr:integer);
    procedure PrintDtlFooter(nr:integer);
    procedure PrintBand (aBand:tAlAbschnitt);
    procedure PrintBandNC (aBand:tAlAbschnitt);
    function  SkipBand (aBand:tAlAbschnitt):boolean;
    procedure FinishPage;
    procedure NewPage;
    Function  RealHeight(aHeight:LongInt):LongInt;
    Function  RealWidth(aWidth:longInt):LongInt;
    Function  LeftMargPix:LongInt;
    Procedure CalcMeasurements;
    procedure DoTheJob;
  protected
    { Protected-Deklarationen }
  public
    { Public-Deklarationen }
    constructor Create (AOwner:TComponent); override;
    destructor  destroy; override;
    procedure Print;
    procedure Preview(VAR ListOfPages:tPages);
    procedure AddNamedValue (const aName,aValue:string);
    procedure ResetData;
    procedure ClearData;
  published
    { Published-Deklarationen }
    property Orientation:tPrinterOrientation read FOrientation write SetOrientation;
    property Papersize  :tPaperSize   read FPapersize   write SetPapersize;
    property LeftMarginMM:integer     read FLeftMargin  write SetleftMargin;
  end;

type
  TAlPrinter = class // replacement for TPrinter enables previewing
  private
    FPreviewing      : boolean;
    FPages           : tPages;  // list of metafiles
    FCurrentMetafile : tDrawMetafile;
    FOrientation     : tPrinterOrientation;
    function  GetCanvas:tCanvas;
    function  GetPageHeight:integer;
    function  GetPageWidth:integer;
    function  GetPageNumber:integer;
    function  GetPageCount:integer;
    procedure SetOrientation(value:tPrinterOrientation);
  protected
    property  Pages:tPages read FPages write FPages;
  public
    constructor Create; virtual;
    destructor  Destroy; virtual;
    procedure BeginDoc;
    procedure EndDoc;
    procedure NewPage;
    property  Canvas:tCanvas read GetCanvas;
    property  PageHeight:integer read GetPageHeight;
    property  PageWidth:integer read GetPageWidth;
    property  PageNumber:integer read GetPageNumber;
    property  Orientation:tPrinterOrientation read FOrientation write SetOrientation;

    property  Previewing:boolean read FPreviewing write FPreviewing;
    property  PageCount:integer read GetPageCount;
  end;

  function AlPrinter:tAlPrinter;

  function LoadReport (const aFileName:string;
                       VAR aReport:tAlReport; VAR aForm:tForm):boolean;

  procedure Register;

const
  ExtDsgn : boolean = false;

implementation

const
   sizes : array[tPapersize] of tPoint =
    ((X:210; Y:297),(X:148;Y:210));
const
  AbschnittName : array[tAbschnittTyp] of string[16] =
     ('Titel','Seitenkopf',
      'Spaltenkopf','Spaltenrumpf','Spaltenfuss',
      'Seitenfuss','Abschluss','Neue Seite',
      'Gruppenkopf','Gruppenfuss');

const
  check_group_header = false;
  check_group_footer = true;

var
    LeftWaist               : integer; { in Pixel }
    TopWaist                : integer; { in Pixel }
    PhyPageWidth            : LongInt; { in Pixel }
    PhyPageHeight           : LongInt;
    PixelsPerInchVertical   : integer;
    PixelsPerInchHorizontal : integer;

type
   tBandList=class(tList)
      procedure SortInsert (aItem:tAlAbschnitt);
   end;

{---------------------------------------------------}

procedure tBandList.SortInsert (aItem:tAlAbschnitt);
var
  i : integer;
begin
  for i:=0 to Count-1 do
   if tAlAbschnitt(Items[i]).Top>aItem.Top then
    begin
      Insert (i,aItem);
      exit;
    end;
  Add (aItem);
end;

{---------------------------------------------------}
VAR
  FAlPrinter : tAlPrinter = NIL;

function AlPrinter:tAlPrinter;
begin
  if NOT Assigned(FAlPrinter) then
     FAlPrinter := tAlPrinter.Create;
  result := FAlPrinter;
end;

constructor tAlPrinter.Create;
begin
  inherited Create;
  FPreviewing := false;
  FPages := tPages.Create;
end;

destructor tAlPrinter.Destroy;
var
  i : integer;
begin
  if Assigned(FCurrentMetafile) then
     FCurrentMetafile.Close;
  for i:=0 to FPages.Count-1 do
      with tDrawMetafile(FPages.Items[i]) do Free;
  FPages.Free;
  inherited Destroy;
end;

procedure tAlPrinter.BeginDoc;
var
  i : integer;
begin
  if FPreviewing then
     FPages.Clear
  else
     Printer.BeginDoc;
end;

procedure tAlPrinter.EndDoc;
begin
  if FPreviewing then
   begin
     if Assigned(FCurrentMetafile) then
        FCurrentMetafile.Close;
     FCurrentMetafile := NIL;
   end
  else
     Printer.EndDoc;
end;

procedure tAlPrinter.NewPage;
begin
  if FPreviewing then
   begin
     if Assigned(FCurrentMetafile) then
        FCurrentMetafile.Close;
     FCurrentMetafile := tDrawMetafile.Create (PhyPageWidth,PhyPageHeight);
     FPages.Add (FCurrentMetafile);
   end
  else
     Printer.NewPage;
end;

Function tAlPrinter.GetCanvas:tCanvas;
begin
  if FPreviewing then
   begin
     if NOT Assigned(FCurrentMetafile) then
        NewPage;
     if Assigned(FCurrentMetafile) then
        result := FCurrentMetafile.Canvas
     else
        raise Exception.Create ('AlPrinter could not assign the Canvas');
   end
  else
     result := Printer.Canvas;
end;

Function tAlPrinter.GetPageHeight:integer;
begin
  if FPreviewing then
     result := PhyPageHeight
  else
     result := Printer.PageHeight;
end;

function tAlPrinter.GetPageWidth:integer;
begin
  if FPreviewing then
     result := PhyPageWidth
  else
     result := Printer.PageWidth;
end;

Function tAlPrinter.GetPageNumber:integer;
begin
  if FPreviewing then
     result := FPages.Count
  else
     result := Printer.PageNumber;
end;

function tAlPrinter.GetPageCount:integer;
begin
  if FPreviewing then
     result := FPages.Count
  else
     result := 0;
end;

procedure tAlPrinter.SetOrientation(value:tPrinterOrientation);
begin
  FOrientation := value;
  if NOT FPreviewing then
     Printer.Orientation := FOrientation;
end;

///////////////////////////////////////////////////////////////////////////////

function tPages.GetPage(index:integer):TGraphic;
begin
  if (index>=0) and (index<Count) then
     result := tDrawMetafile(Items[index])
  else
     result := NIL;
end;

procedure tPages.Clear;
var
  i : integer;
begin
  for i:=0 to Count-1 do
     with tDrawMetafile(Items[i]) do Free;
  inherited Clear;
end;
///////////////////////////////////////////////////////////////////////////////

procedure TAlDetailLink.SetDetailBand (value:tAlAbschnitt);
begin
  if csDesigning in ComponentState then
     if Assigned(FDetailBand) then
        FDetailBand.FDetailLink := NIL;
     if Assigned(value) then
      begin
        FDetailBand := value;
        FDetailBand.FDetailLink := Self;
      end;
end;

function TAlDetailLink.CheckChanged (check_for:boolean):boolean;
begin
  result := false;
  if Assigned(FDataSource) then
   begin
     if check_for=check_group_footer then
      begin
        if Assigned(pChar(lastval)) then
           result := lastval<>FDataSource.NextValue
        else
           result := FALSE;
      end
     else // for header
      begin
        if Assigned(pChar(lastval)) then
           result := lastval<>FDataSource.value
        else
           result := TRUE;
        // get new value
        lastval := FDataSource.value;
      end;
   end;
end;

constructor tAlReport.Create (AOwner:tComponent);
begin
   inherited Create (AOwner);
   FOrientation := poPortrait;
   FPapersize   := alr_A4;
   if csDesigning in ComponentState then
      UpdateScrollBars
   else
    with Owner as TForm do begin
      HorzScrollBar.Position := 0;
      VertScrollBar.Position := 0;
    end;
end;

destructor tAlReport.destroy;
begin
   inherited destroy;
end;

procedure tAlReport.AddNamedValue (const aName,aValue:string);
var
  i       : integer;
  current : tAlControl;
begin
   for i:=0 to Owner.ComponentCount-1 do
    if Owner.Components[i] is tAlControl then
     begin
       current := tAlControl(Owner.Components[i]);
       if UpperCase(current.Name)=UpperCase(aName) then
        begin
          current.FValues.Add(aValue);
          exit;
        end;
     end;
end;

procedure tAlReport.ResetData;
var
  i       : integer;
  current : tAlControl;
begin
   for i:=0 to Owner.ComponentCount-1 do
    if Owner.Components[i] is tAlControl then
     begin
       current := tAlControl(Owner.Components[i]);
       current.ResetData;
     end;
end;

Procedure tAlReport.ClearData;
var
  current : tAlControl;
  i       : integer;
begin
   for i:=0 to Owner.ComponentCount-1 do
    if Owner.Components[i] is tAlControl then
     begin
       current := tAlControl(Owner.Components[i]);
       current.ClearData;
     end;
end;

procedure tAlReport.UpdateScrollBars;
begin
   with tForm(Owner) do
    begin
      if FOrientation=poPortrait then
       begin
         HorzScrollBar.Range := (sizes[FPapersize].X*38) div 10;
         VertScrollBar.Range := (sizes[FPapersize].Y*38) div 10;
       end
      else
       begin
         VertScrollBar.Range := (sizes[FPapersize].X*38) div 10;
         HorzScrollBar.Range := (sizes[FPapersize].Y*38) div 10;
       end
    end;
end;

procedure tAlReport.SetOrientation (value:tPrinterOrientation);
begin
   if value<>FOrientation then
    begin
      FOrientation := value;
      if csDesigning in ComponentState then
         UpdateScrollBars;
    end;
end;

procedure tAlReport.SetPapersize (value:tPapersize);
begin
   if value<>FPapersize then
    begin
      FPapersize := value;
      if csDesigning in ComponentState then
         UpdateScrollBars;
    end;
end;

procedure tAlReport.SetLeftmargin(value:integer);
begin
   if (value>=0) and (value<Sizes[FPaperSize].X) then
      FLeftMargin := value;
end;

Procedure tAlReport.FinishPage;
var
  i : integer;
begin
  YPos := MaxYPos;
  for i:=0 to PgeFooters.Count-1 do
     PrintBandNC(PgeFooters.Items[i]);
end;

Procedure tAlReport.NewPage;
var
  i : integer;
begin
  if NOT FirstPage then
     AlPrinter.NewPage;
  FirstPage := False;
  YPos := 0;
  for i:=0 to PgeHeaders.Count-1 do
     PrintBandNC(PgeHeaders.Items[i]);
end;

Function tAlReport.RealHeight(aHeight:LongInt):LongInt;
var
  PaperHeight : integer;
begin
   // convert Screen Pixel <aHeight> to PrinterPixel <result>
   //
   if FOrientation=poPortrait then
      PaperHeight := Sizes[FPaperSize].Y
   else
      PaperHeight := Sizes[FPaperSize].X;

   // result := ( (aHeight*10*PhyPageHeight) div 38) div PaperHeight;
   result := round(aHeight * PixelsPerInchVertical / Screen.PixelsPerInch);
end;

Function tAlReport.RealWidth(aWidth:LongInt):LongInt;
var
   PaperWidth : integer;
begin
   if FOrientation=poPortrait then
      PaperWidth := Sizes[FPaperSize].X
   else
      PaperWidth := Sizes[FPaperSize].Y;

  // result := ( (aWidth*10*PhyPageWidth) div 38) div PaperWidth;
  result := round (aWidth * PixelsPerInchHorizontal / Screen.PixelsPerInch);
end;

Function tAlReport.LeftMargPix:LongInt;
var
   PaperWidth : integer;
begin
   if FOrientation=poPortrait then
      PaperWidth := Sizes[FPaperSize].X
   else
      PaperWidth := Sizes[FPaperSize].Y;
   // convert leftMargin in mm to Device Pixels
   result := round(leftMarginMM * PixelsPerInchHorizontal / 24.5) - LeftWaist;
//   result := (LeftMarginMM*PhyPageWidth) div PaperWidth -LeftWaist;
end;

procedure tAlReport.PrintBandNC (aBand:tAlAbschnitt);
var
  i       : integer;
  c       : tAlControl;
  X,Y,W,H : LongInt;
  R       : tRect;
begin
  if aBand.AltColor then
   begin
     if aBand.Alt then
      begin
        R := Rect(LeftMargPix+RealWidth(aBand.left), yPos,
                  RealWidth(aBand.Width), yPos+RealHeight(aBand.Height)-1);
        AlPrinter.Canvas.Brush.Color := aBand.Color;
        AlPrinter.Canvas.FillRect (R);
      end;
     aBand.Alt := NOT aBand.Alt;
   end;
  for i:=0 to aBand.ControlCount-1 do
   begin
     c := tAlControl(aBand.Controls[i]);
     Y := YPos+RealHeight(c.top);
     X := LeftMargPix+RealWidth(aBand.left+c.left);
     W := RealWidth (c.width);
     H := RealHeight (c.height);
     c.Print (X,Y,W,H);
   end;
  YPos := YPos + RealHeight(aBand.Height);
end;

function tAlReport.SkipBand (aBand:tAlAbschnitt):boolean;
var
  more : boolean;
  c    : tAlControl;
  i    : integer;
begin
  result := false;
  for i:=0 to aBand.ControlCount-1 do
   begin
     c := tAlControl(aBand.Controls[i]);
     more := c.Skip;
     result := result OR more;
   end;
end;

procedure tAlReport.PrintDtlHeader(nr:integer);
var
  j : integer;
begin
  if nr<>0 then
     for j:=0 to DtlHeaders.Count-1 do
        if tAlAbschnitt(DtlHeaders.Items[j]).Tag=nr then
           PrintBand (DtlHeaders.Items[j]);
end;

procedure tAlReport.PrintDtlFooter(nr:integer);
var
  j : integer;
begin
  if nr<>0 then
     for j:=0 to DtlFooters.Count-1 do
        if tAlAbschnitt(DtlFooters.Items[j]).Tag=nr then
           PrintBand (DtlFooters.Items[j]);
end;

Procedure tAlReport.PrintBand (aBand:tAlAbschnitt);
var
  more : boolean;
begin
  if aBand.FAbschnittTyp=alr_NewPage then
   begin
     FinishPage;
     // NewPage;
   end
  else
   repeat
     if YPos+RealHeight(aBand.Height)>MaxYPos then
      begin
        FinishPage;
        // conditionally print page headers
        NewPage;
        // if exist, print the detail header
        if aBand.FAbschnittTyp=alr_Spalte then
         begin
           PrintDtlHeader (aBand.Tag);
           // when band is detail-linked then print group header
           if Assigned(aBand.FDetailLink) then
            begin
              with aBand.FDetailLink do
               begin
                 CheckChanged (check_group_header);
                 if Assigned(FGruppenkopf) then
                    PrintBand (FGruppenKopf);
               end;
            end;
         end;
      end;
     if Assigned(aBand.FDetailLink) then
      begin
        with aBand.FDetailLink do
           if CheckChanged (check_group_header) then
              if Assigned(FGruppenkopf) then
                 PrintBand (FGruppenKopf);
      end;

     PrintBandNC (aBand);

     if Assigned(aBand.FDetailLink) then
      begin
        with aBand.FDetailLink do
          if CheckChanged (check_group_footer) then
             if Assigned(FGruppenFuss) then
                PrintBand (FGruppenFuss);
      end;

     if aBand.FAbschnittTyp=alr_Spalte then
        more := SkipBand (aBand)
     else
        more := false;

   until (NOT more);
end;

Procedure tAlReport.CalcMeasurements;
var
   FWaist      : tPoint;
   FPhySize    : tPoint;
   TextMetrics : TTextMetric;
begin
(*
   GetTextMetrics( Printer.{Canvas.}Handle,TextMetrics );
   { Calculate the number of pixels per inch vertical and horizontal.
     'GetDeviceCaps' is a Windows API call. }
*)
   PixelsPerInchVertical   := GetDeviceCaps( Printer.Handle,LOGPIXELSY );
   PixelsPerInchHorizontal := GetDeviceCaps( Printer.Handle,LOGPIXELSX );
(**)
   { Get the gutter on the left and top.  'Escape' is a Windows API call. }
   Escape( Printer.{Canvas.}Handle,GETPRINTINGOFFSET,0,Nil,@FWaist);
   LeftWaist := FWaist.X;
   TopWaist  := FWaist.Y;
   Escape( Printer.{Canvas.}Handle,GETPHYSPAGESIZE,0,Nil,@FPhySize);
   PhyPageWidth  := FPhySize.X;
   PhyPageHeight := FPhySize.Y;
end;

procedure tAlReport.Print;
begin
  AlPrinter.Previewing := false;

  Printer.Orientation := FOrientation;
  AlPrinter.BeginDoc;
  CalcMeasurements;

  ResetData;
  DoTheJob;
end;

procedure tAlReport.Preview(VAR ListOfPages:tPages);
begin
  AlPrinter.Previewing := true;

  AlPrinter.Orientation := FOrientation;
  //  CalcMeasurements;
  PixelsPerInchVertical := Screen.PixelsPerInch;
  PixelsPerInchHorizontal := PixelsPerInchVertical;
  if FOrientation=poPortrait then
   begin
     PhyPageWidth  {pxl} := round (PixelsPerInchHorizontal * sizes[FPapersize].x / 24.5);
     PhyPageHeight {pxl} := round (PixelsPerInchVertical   * sizes[FPapersize].y / 24.5);
   end
  else
   begin
     PhyPageWidth  {pxl} := round (PixelsPerInchHorizontal * sizes[FPapersize].y / 24.5);
     PhyPageHeight {pxl} := round (PixelsPerInchVertical   * sizes[FPapersize].x / 24.5);
   end;
  LeftWaist := 0;
  TopWaist  := 0;

  AlPrinter.Pages := ListOfPages;
  AlPrinter.BeginDoc;

  ResetData;
  DoTheJob;
end;

Procedure tAlReport.DoTheJob;
var
   i,j      : integer;
   templist : tBandList;
   current  : tAlAbschnitt;
   lastab   : tAbschnittTyp;
   lastTag  : integer;
begin
   { initialization }
   {----------------}
   { count and sort Abschnitte }
   templist := tBandList.Create;
   for i:=0 to Owner.ComponentCount-1 do
    if Owner.Components[i].ClassType=tAlAbschnitt then
     begin
       current := tAlAbschnitt(Owner.Components[i]);
       templist.SortInsert (current);
     end;

   RptHeaders := tBandList.Create;
   PgeHeaders := tBandList.Create;
   DtlHeaders := tBandList.Create;
   Details    := tBandList.Create;
   DtlFooters := tBandList.Create;
   PgeFooters := tBandList.Create;
   RptFooters := tBandList.Create;
   for i:=0 to templist.Count-1 do
    begin
      current := templist.Items[i];
      with current do
       begin
         case FAbschnittTyp of
           alr_titel       : RptHeaders.Add(current);
           alr_seitenkopf  : PgeHeaders.Add(current);
           alr_spaltenkopf : begin
                               current.Tag := i+1;
                               lastTag     := i+1;
                               DtlHeaders.Add(current);
                             end;
           alr_spalte      : begin
                               if lastab=alr_spaltenkopf then
                                  current.Tag := lastTag
                               else
                                  lastTag := i+1;
                               Details.Add(current);
                             end;
           alr_newPage     : Details.Add(current);
           alr_spaltenfuss : begin
                               if lastab=alr_spalte then
                                  current.Tag := lastTag;
                               DtlFooters.Add(current);
                             end;
           alr_seitenfuss  : PgeFooters.Add(current);
           alr_ende        : RptFooters.Add(current);
         end;
         lastab := FAbschnittTyp;
       end;
    end;
   templist.free;

   { preparation }
   {-------------}
   MaxYPos := AlPrinter.PageHeight;
   for i:=0 to PgeFooters.Count-1 do
    begin
      current := PgeFooters.Items[i];
      MaxYPos := MaxYPos - RealHeight(current.Height);
    end;

   { printing }
   {----------}
   YPos := 99999;
   FirstPage := true;
   { print the Report-Header(s) }
   for i:=0 to RptHeaders.Count-1 do
      PrintBand (RptHeaders.Items[i]);
   { print Details }
   for i:=0 to Details.Count-1 do
    begin
      current := tAlAbschnitt(Details.Items[i]);
      { conditionaly print the Detail-Header(s) }
      PrintDtlHeader(current.Tag);
      { print the Detail }
      PrintBand (current);
      { conditionaly print the Detail-Footer(s) }
      PrintDtlFooter(current.Tag);
    end;
   { print the Report-Footer(s) }
   for i:=0 to RptFooters.Count-1 do
      PrintBand (RptFooters.Items[i]);
   FinishPage;
   AlPrinter.EndDoc;

   { Cleanup }
   RptHeaders.Free;
   PgeHeaders.Free;
   DtlHeaders.Free;
   Details.Free;
   DtlFooters.Free;
   PgeFooters.Free;
   RptFooters.Free;
end;

{---------------------------------------------------}

constructor tAlAbschnitt.Create (AOwner:tComponent);
begin
   inherited Create (AOwner);
   Color      := clWhite;
   BevelInner := bvNone;
   BevelOuter := bvNone;
   Ctl3D      := False;
   Caption    := '';
   Align      := alTop;

   FAbschnittTyp := alr_Titel;
end;

procedure tAlAbschnitt.SetAbschnittTyp(value:tAbschnittTyp);
begin
  if value<>FAbschnittTyp then
   begin
     FAbschnittTyp := value;
     Refresh;
   end;
end;

procedure tAlAbschnitt.Paint;
var
   i : integer;
begin
  inherited Paint;
  if (csDesigning in ComponentState) or ExtDsgn then
   begin
     Canvas.Pen.Color  := clSilver;
     Canvas.Font.Color := clSilver;
     Canvas.Font.Size  := 8;
     Canvas.Font.Name  := 'System';
     for i:=1 to Width div 38 do
      begin
        Canvas.MoveTo (i*38,0);
        Canvas.LineTo (i*38,Height);
        if FAbschnittTyp=alr_Titel then
           Canvas.TextOut (i*38,0,IntToStr(i)+'cm');
        Canvas.TextOut (0,10,AbschnittName[FAbschnittTyp]);
      end;
     for i:=1 to Height div 38 do
      begin
        Canvas.MoveTo (0,i*38);
        Canvas.Lineto (Width,i*38);
      end;
   end;
end;

{---------------------------------------------------}

constructor tAlControl.Create (AOwner:tComponent);
begin
  inherited Create (AOwner);
  Autosize := FALSE;
  if csDesigning in ComponentState then
    FValues := NIL
  else
   begin
     FValues := tStringList.Create;
     FValues.duplicates := dupAccept;
     dIndex := 0;
   end;
end;

destructor tAlControl.Destroy;
begin
  FValues.Free;
  inherited destroy;
end;

procedure tAlControl.ResetData;
begin
  dIndex := 0;
end;

procedure tAlControl.ClearData;
begin
  FValues.Clear;
  dIndex := 0;
end;

function tAlControl.Skip:boolean;
begin
  result := false;
  if FValues.Count>1 then
   begin
     if dIndex<FValues.Count then
        inc (dIndex);
     result := dIndex<FValues.Count;
   end;
end;

procedure tAlControl.PrintOut (X,Y,W,H:integer; const s:string);
begin
  if NOT Transparent then
     AlPrinter.Canvas.Brush.Assign (Self.Canvas.Brush)
  else
     AlPrinter.Canvas.Brush.Style := bsClear;
  AlPrinter.Canvas.Pen.Assign (Self.Canvas.Pen);
  AlPrinter.Canvas.Font.Assign (Self.Font);
  case Alignment of
    taLeftJustify : begin
                      SetTextAlign (AlPrinter.Canvas.Handle,TA_LEFT);
                      AlPrinter.Canvas.TextOut (X,Y,s);
                    end;
    taCenter      : begin
                      SetTextAlign (AlPrinter.Canvas.Handle,TA_CENTER);
                      AlPrinter.Canvas.TextOut (X+W div 2,Y,s);
                    end;
    taRightJustify: begin
                      SetTextAlign (AlPrinter.Canvas.Handle,TA_RIGHT);
                      AlPrinter.Canvas.TextOut (X+W,Y,s);
                    end;
  end;
end;

procedure tAlControl.Print (X,Y,W,H:integer);
begin
  if visible then
     PrintOut (X,Y,W,H,Caption);
end;

{---------------------------------------------------}

constructor tAlShape.Create (AOwner:tcomponent);
begin
  inherited Create (AOwner);
  Caption := '';
  height := 65;
  width  := 65;
  Transparent := TRUE;
  FShape := stRectangle;
  FBrush := tBrush.Create;
  FBrush.OnChange := StyleChanged;
  FPen   := tPen.Create;
  FPen.OnChange := StyleChanged;
end;

destructor tAlShape.Destroy;
begin
  FBrush.Free;
  FPen.Free;
  inherited destroy;
end;

procedure tAlShape.StyleChanged(Sender:tObject);
begin
  Refresh;
end;

procedure tAlShape.SetBrush (value:tBrush);
begin
  FBrush.Assign (value);
end;

procedure tAlShape.SetPen (value:tPen);
begin
  FPen.Assign (value);
end;

procedure tAlShape.SetShape (value:tShapeType);
begin
  if FShape<>value then
   begin
     FShape := value;
     Refresh;
   end;
end;

procedure tAlShape.Print (X,Y,W,H:integer);
var
   ax,ay,aw,ah,s : Longint;
begin
  if visible then
     with AlPrinter.Canvas do
      begin
        Pen.Assign (FPen);
        if Pen.Width<1 then Pen.Width := 1;
        Brush.Assign (FBrush);
        aw := w;
        ah := h;
        if aw<ah then s := aw else s := ah;
        case FShape of
          stRectangle, stRoundRect, stEllipse :
           begin
             ax := x+0;
             ay := y+0;
           end;
          stSquare, stRoundSquare, stCircle :
           begin
             ax := x+(aw-s) div 2;
             ay := y+(ah-s) div 2;
             aw := s;
             ah := s;
           end;
        end;
        case FShape of
           stRectangle,
           stSquare      : if (aw<=1) or (ah<=1) then
                            begin
                              MoveTo (ax,ay);
                              if aw<=1 then LineTo (ax{+aw},ay+ah)
                                       else LineTo (ax+aw,ay{+ah});
                            end
                           else
                              Rectangle (ax,ay,ax+aw,ay+ah);
           stRoundRect,
           stRoundSquare : RoundRect (ax,ay,ax+aw,ay+ah,s div 4, s div 4);
           stEllipse,
           stCircle      : Ellipse (ax,ay,ax+aW,ay+ah);
        end;
      end; // with AlPrinter.Canvas do
end;

procedure tAlShape.Paint;
var
   x,y,w,h,s : integer;
begin
  with Canvas do
   begin
     Pen := FPen;
     Brush := FBrush;
     w := width;
     h := height;
     if w<h then s := w else s := h;
     case FShape of
       stRectangle, stRoundRect, stEllipse :
        begin
          x := 0;
          y := 0;
        end;
       stSquare, stRoundSquare, stCircle :
        begin
          x := (w-s) div 2;
          y := (h-s) div 2;
          w := s;
          h := s;
        end;
     end;
     case FShape of
        stRectangle,
        stSquare      : if (w<=1) or (h<=1) then
                         begin
                           MoveTo (x,y);
                           if w<=1 then LineTo (x{+w},y+h)
                                   else LineTo (x+w,y{+h});
                         end
                        else
                           Rectangle (x,y,x+w,y+h);
        stRoundRect,
        stRoundSquare : RoundRect (x,y,x+w,y+h,s div 4, s div 4);
        stEllipse,
        stCircle      : Ellipse (x,y,x+W,y+h);
     end;
   end;
end;

{---------------------------------------------------}

constructor tAlImage.Create (AOwner:tComponent);
begin
  inherited Create (AOwner);
  FAutosize := false;
  FStretch  := true;
  FCenter   := true;
  height    := 100;
  width     := 100;

  FPicture  := tPicture.Create;
  {FPicture.Graphic.OnChange := PicChanged;}
  aPen := tPen.Create;    { used when no picture is loaded }
  aPen.Color := clBlack;
  aPen.Style := psDashDot;
end;

destructor tAlImage.Destroy;
begin
  aPen.Free;
  FPicture.Free;
  inherited destroy;
end;

procedure tAlImage.WMSize (var Message: TWMSize);
begin
end;

procedure tAlImage.PicChanged (Sender:tObject);
begin
  if csLoading in ComponentState then
     { do not draw image }
  else
   begin
     if FAutosize then
      begin
        width  := Picture.Width;
        height := Picture.height;
      end;
     Invalidate;
   end;
end;

procedure tAlImage.Paint;
var
  x,y : integer;
begin
  if FPicture.Graphic is tBitmap then
   begin
     if FStretch then
        Canvas.StretchDraw (Rect(0,0,width,height),FPicture.Graphic)
     else if FCenter then
      begin
        x := (width-FPicture.width) div 2;
        y := (height-FPicture.height) div 2;
        Canvas.Draw (x,y,FPicture.Graphic);
      end
     else
        Canvas.Draw (0,0,FPicture.Graphic);
   end
  else with Canvas do
   begin
     Pen.Assign(aPen);
     Rectangle (0,0,width,height);
   end;
end;

procedure tAlImage.Print (X,Y,W,H:integer);
var
  ax,ay : integer;
  aBitmap : tBitmap;
begin
  if NOT visible then
     exit;

  if FPicture.Graphic is tBitmap then
   begin
     if FStretch then
        AlPrinter.Canvas.StretchDraw (Rect(X,Y,X+W,Y+H),FPicture.Graphic)
     else
      begin
        if FCenter then
         begin
           ax := (width-FPicture.width) div 2;
           ay := (height-FPicture.height) div 2;
         end
        else
         begin
           ax := 0;
           ay := 0;
         end;
        aBitmap := tBitmap.Create;
        aBitmap.height := height;
        aBitmap.width  := width;
        aBitmap.Canvas.Draw (ax,ay,FPicture.Graphic);
        AlPrinter.Canvas.StretchDraw (Rect(X,Y,X+W,Y+H),aBitmap);
        aBitmap.Free;
      end;
   end
  else
   begin
     AlPrinter.Canvas.Pen.Assign(aPen);
     AlPrinter.Canvas.Rectangle (X,Y,w,h);
   end;
end;

procedure tAlImage.SetCenter(value:boolean);
begin
  if value<>FCenter then
   begin
     FCenter := value;
     Invalidate;
   end;
end;

procedure tAlImage.SetStretch(value:boolean);
begin
  if value<>FStretch then
   begin
     FStretch := value;
     Invalidate;
   end;
end;

procedure tAlImage.SetAutosize(value:boolean);
begin
  if value<>FAutosize then
   begin
     FAutosize := value;
     if value then
      begin
        width := Picture.Width;
        height := Picture.height;
      end;
     Invalidate;
   end;
end;

procedure tAlImage.SetPicture(value:tPicture);
begin
  FPicture.Assign(value);
  Invalidate;
end;

{---------------------------------------------------}

constructor tAlFeld.Create (aOwner:tComponent);
begin
  inherited Create (aOwner);
  Autosize := true;
end;

procedure tAlFeld.Print (X,Y,W,H:integer);
begin
  if visible then
     PrintOut (X,Y,W,H,Value);
end;

function tAlFeld.GetValue:string;
var
  n : string;
  i : integer;
begin
  if FValues.Count=0 then
   begin
     if Name[length(Name)]='_' then
      begin
        n := Name; while n[length(n)]='_' do n:= copy(n,1,length(n)-1);
        for i:=0 to Owner.ComponentCount-1 do
         if n=Owner.Components[i].Name then
          begin
            result := tAlFeld(Owner.Components[i]).Value;
            exit;
          end;
        result := Caption;
      end
     else
        result := Caption;
   end
  else if dIndex<FValues.Count then
     result := FValues.Strings[dIndex]
  else if FValues.Count=1 then
     result := FValues.Strings[0]
  else
     result := '~';
end;

function tAlFeld.GetNextValue:string;
var
  n : string;
  i : integer;
begin
  if FValues.Count=0 then
   begin
     if Name[length(Name)]='_' then
      begin
        n := Name; while n[length(n)]='_' do n:= copy(n,1,length(n)-1);
        for i:=0 to Owner.ComponentCount-1 do
         if n=Owner.Components[i].Name then
          begin
            result := tAlFeld(Owner.Components[i]).NextValue;
            exit;
          end;
        result := Caption;
      end
     else
        result := Caption;
   end
  else if dIndex+1<FValues.Count then
     result := FValues.Strings[dIndex+1]
  else if FValues.Count=1 then
     result := FValues.Strings[0]
  else
     result := '~';
end;
{---------------------------------------------------}

constructor tAlSysFeld.Create (AOwner:tComponent);
begin
   inherited Create (AOwner);
   Autosize   := true;
   Color      := clWhite;
   Transparent:= true;

   FSysDataType := alr_Time;
end;

Procedure tAlSysFeld.Print (X,Y,W,H:integer);
var
   s : string;
begin
   case FSysDataType of
     alr_Time     : s := TimetoStr(Time);
     alr_Date     : s := DateToStr(Date);
     alr_DateTime : s := DateTimeToStr(Now);
     alr_PageNum  : s := IntToStr(AlPrinter.PageNumber);
     alr_Zaehler  : s := IntToStr(1+dIndex);
     alr_Anzahl   : s := 'E';
   end;
  PrintOut (X,Y,W,H,s);
end;

function tAlSysFeld.Skip:boolean;
begin
  result := false;
  inc (dIndex);
end;

Procedure tAlSysFeld.SetSysDataType (value:tAlSysDataType);
begin
   if value<>FSysDataType then
    begin
      FSysDataType := value;
      case FSysDataType of
         alr_Time     : Caption := '#hh:mm:ss#';
         alr_Date     : Caption := '#tt.mm.jjjj#';
         alr_DateTime : Caption := '#tt.mm.jjjj hh:mm:ss#';
         alr_PageNum  : Caption := '#Seite';
         alr_Zaehler  : Caption := '#Zaehler';
         alr_Anzahl   : Caption := '#Anzahl';
      end;
    end;
end;

function FindReport (aForm:tForm):tAlReport;
var
  i : integer;
begin
  result := NIL;
  for i:=0 to aForm.ComponentCount-1 do
     if aForm.Components[i] is tAlReport then
        result := aForm.Components[i] as tAlReport;
end;

function LoadReport (const aFileName:string;
                     VAR aReport:tAlReport; VAR aForm:tForm):boolean;
begin
  result := false;
  if FileExists (aFileName) then
   begin
     try
       aForm   := tForm.Create (Application);
       aForm   := ReadComponentResFile (aFileName,aForm) as tForm;
       aReport := FindReport (aForm);
       result := Assigned(aReport);
     except
       on E:Exception do
        begin
          aForm.Free;
          showmessage (e.message);
        end;
     end; // try
   end; // if FileExists
end;

procedure Register;
begin
  RegisterComponents('AlRep', [TAlReport,TAlAbschnitt,TAlFeld,
                               TAlSysFeld,TAlShape,TAlImage,TAlDetailLink]);
end;

Initialization
  fAlPrinter := NIL;
  RegisterClasses ([TAlReport,TAlAbschnitt,TAlFeld,
                    TAlSysFeld,TAlShape,
                    TAlImage,TAlDetailLink]);
finalization
  if assigned(fAlPrinter) then
     FAlPrinter.Free;
end.