{
by Peter During
2010
}
// Erzeugung über aPDPrinter:=TPDPrinter.Create('');
// Parameter ''=der selbe wie bei Printer
//           ansonsten wird dieser dann gesetzt.
unit PDPrinter;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,Printers,graphics,LCLType;

const
  TRCENTER=0;
  TRLEFT=1;
  TRRIGHT=2;

type

  TLineSpacing=(lsHalfSpace,lsSingleSpace,lsSingleAndAHalf,lsDoubleSpace);

  TPDPrinterEvent = procedure(Sender: TObject) of object;

  TTableRow=record
    TextAllign:integer;
    RowPos:integer;
    RowWidth:integer;
  end;

  PTableRow=^TTableRow;

  TTableRows=array of TTableRow;

  PTableRows=^TTableRows;

  { TPDPrinter }

  TPDPrinter=class
  private
    aBorder: boolean;
    aLineSpacing: integer;
    aOnBeginDoc: TPDPrinterEvent;
    aOnEndDoc: TPDPrinterEvent;
    aOnNewLine: TPDPrinterEvent;
    aOnNewPage: TPDPrinterEvent;
    aPage: integer;
    aPrinter:TPrinter;
    aLine:integer;
    aMMX:integer;
    aMMY:integer;
    amarginetop:integer;
    ls:TLineSpacing;
    amargineleft:integer;
    amargineright:integer;
    amarginebottom:integer;
    aTableRows:TTableRows;
    // Header-Vars:
    aHeaderFormat:TTableRows;
    aHeader:string;
    aHeaderFont:TFont;
    isheader:boolean;
    //--
    // Footer-Vars:
    aFooterFormat:TTableRows;
    aFooter:string;
    aFooterFont:TFont;
    isfooter:boolean;
    //--
    _linepos:integer;
//    aTextMetric:TTextMetric;
    function GetLineSpacing: TLineSpacing;
    function GetPageHight: integer;
    function GetPageWidth: integer;
    function GetXDPI:integer;
    function GetYDPI: integer;
    procedure SetFont(const AValue: TFont);
    function GetFont:TFont;
    procedure AdjustMM;
    procedure SetLineSpacing(const AValue: TLineSpacing);
    procedure SetTableFormat(s:string; aTable:PTableRows);
    procedure WriteaTable(s:string; aTable:PTableRows);
    procedure WriteaTableX(s:string; aTable:PTableRows; aX:integer);
    procedure WriteFooter;
    function GetFooterHight:integer;
    procedure WriteHeader;
    function ParseStr(astr:string):string;
  public
    // Constructor, Destructor:
    constructor Create(APrinters:string='');
    destructor Destroy; override;
    //--
    procedure BeginDoc;
    procedure EndDoc;
    property Page:integer read aPage;
    property Line:integer read aLine;
    // Seitengrößen:
    property PageWidth:integer read GetPageWidth;
    property PageHight:integer read GetPageHight;
    //--
    // Tabellen-Krams:
    procedure SetTableLineFormat(s:string);
    procedure SetHeaderFormat(s:string);
    procedure SetFooterFormat(s:string);
    //--
    // Angabe in DPI:
    property XDPI:integer read GetXDPI;
    property YDPI:integer read GetYDPI;
    //--
    // Angabe in px:
    property LineSpacing:TLineSpacing read GetLineSpacing write SetLineSpacing default lsSingleSpace;
//    property LineSpacing:integer read aLineSpacing write aLineSpacing default 20;
    //--
    // Write-Proceduren:
    procedure WriteLine(s:string);
    procedure WriteLineRight(s:string);
    procedure WriteLineCenter(s:string);
    procedure WriteTableLine(s:string);
    procedure WritePos(s:string; X,Y:integer);
    //--
    // Linefeed-Procedure:
    procedure NewLine;
    //--
    procedure NewPage;
  published
    //Header und Footer:
    property Header:string read aHeader write aHeader;
    property HeaderFont:TFont read aHeaderFont write aHeaderFont;
    property Footer:string read aFooter write aFooter;
    property FooterFont:TFont read aFooterFont write aFooterFont;
    //--
    // Angabe in mm:
    property MargineTop:integer read aMargineTop write aMargineTop default 0;
    property MargineLeft:integer read aMargineLeft write aMargineLeft default 0;
    property MargineRight:integer read aMargineRight write aMargineRight default 0;
    property MargineBottom:integer read aMargineBottom write aMargineBottom default 0;
    //--
    property Font:TFont read GetFont write SetFont;
    property Border:boolean read aBorder write aBorder default false;
    // Events:
    property OnBeginDoc:TPDPrinterEvent read aOnBeginDoc write aOnBeginDoc;
    property OnEndDoc:TPDPrinterEvent read aOnEndDoc write aOnEndDoc;
    property OnNewLine:TPDPrinterEvent read aOnNewLine write aOnNewLine;
    property OnNewPage:TPDPrinterEvent read aOnNewPage write aOnNewPage;
    //--

  end;


implementation


{ TPDPrinter }

constructor TPDPrinter.Create(aprinters:string='');
begin
  inherited Create;
  if aprinters<>'' then
    Printer.SetPrinter(aprinters);// else
    //aPrinter.SetPrinter(aprinters) else
//    raise Exception.Create(''''' ist ein unbekanter Drucker!');
  aPrinter:=Printer;
  SetLength(aHeaderFormat,0);
  SetLength(aFooterFormat,0);
  with aPrinter.Canvas do
  begin
     Font.Name := 'Courier New';
     Font.Size := 10;
     Font.Style:= [];
  end;
  aHeaderFont:=TFont.Create;
  with aHeaderFont do
  begin
     Font.Name := 'Courier New';
     Font.Size := 10;
     Font.Style:= [];
  end;
  aFooterFont:=TFont.Create;
  with aFooterFont do
  begin
     Font.Name := 'Courier New';
     Font.Size := 10;
     Font.Style:= [];
  end;
  aHeader:='';
  aFooter:='';
end;



function TPDPrinter.GetXDPI: integer;
begin
  result:=aPrinter.XDPI;
end;

function TPDPrinter.GetLineSpacing: TLineSpacing;
begin
  result:=ls;
end;

function TPDPrinter.GetPageHight: integer;
begin
  result:=aPrinter.PageHeight;
end;

function TPDPrinter.GetPageWidth: integer;
begin
  result:=aPrinter.PageWidth;
end;

function TPDPrinter.GetYDPI: integer;
begin
  result:=aPrinter.YDPI;
end;

procedure TPDPrinter.SetFont(const AValue: TFont);
begin
  aPrinter.Canvas.Font.Assign(aValue);
//  aPrinter.Canvas.Font.Size:=aValue.Size;
  SetLineSpacing(LineSpacing);
end;

function TPDPrinter.GetFont: TFont;
begin
  result:=aPrinter.Canvas.Font;
end;

procedure TPDPrinter.AdjustMM;
begin
  //25.4 mm = 1 inch
  aMMX:=round(XDPI / 25.4);
  aMMY:=round(YDPI / 25.4);
end;

procedure TPDPrinter.SetLineSpacing(const AValue: TLineSpacing);
var H:integer;
begin
  ls:=AValue;
  H:=aPrinter.Canvas.TextHeight('M');
  case aValue of
  lsHalfSpace:aLineSpacing:=H shr 1;    // H div 2
  lsSingleSpace:aLineSpacing:=H;
  lsSingleAndAHalf:aLineSpacing:=H+(H shr 1);
  lsDoubleSpace:aLineSpacing:=H+H;
  end;
end;

procedure TPDPrinter.SetTableFormat(s: string; aTable: PTableRows);
var i:integer=1;
    x:integer;
    ac:char;
    ar:PTableRow=nil;
begin
  if s='' then raise exception.Create(''''' ist ein ungültiges Tabel Format!');
  SetLength(aTable^,1);
  ar:=@aTable^[High(ATable^)];
  ar^.RowPos:=0;
  ar^.TextAllign:=TRLeft;
  ar^.RowWidth:=0;
  while i<=Length(s) do
  begin
    ac:=s[i];
    if ac in ['0'..'9'] then
    begin
      while (ac in ['0'..'9']) and (i<=Length(s)) do
      begin
        ar^.RowWidth:=strtoint(inttostr(ar^.RowWidth)+ac);
        Inc(i);
        if i<=Length(s) then
          ac:=s[i] else inc(i);
      end;
      if High(aTable^)>0 then
          ar^.RowPos:=aTable^[High(aTable^)-1].RowPos+aTable^[High(aTable^)-1].RowWidth;
    end else
    if ac in ['<','>','^'] then
    begin
      case ac of
      '<': ar^.TextAllign:=TRLEFT;
      '>': ar^.TextAllign:=TRRIGHT;
      '^': ar^.TextAllign:=TRCENTER;
      end;
      Inc(i);
    end else
    if ac='|' then
    begin
    // neue Spalte:
      SetLength(aTable^,Length(aTable^)+1);
      ar:=@aTable^[High(ATable^)];
      ar^.RowPos:=0;
      ar^.TextAllign:=TRLeft;
      Inc(i);
    end else
      raise Exception.Create(''''+ac+''' ist kein gültiger Token!');
  end;
end;

procedure TPDPrinter.WriteaTable(s: string; aTable: PTableRows);
var str:string='';
    i:integer=1;
    x:integer=0;
    ar:PTableRow=nil;
begin
  while i<Length(s) do
  begin
    ar:=@aTable^[x];
    //Auszugebenen String zusammenknüpfen:
    While (s[i]<>'|') and (i<=Length(s)) do
    begin
      str:=str+s[i];
      Inc(i);
    end;
    str:=ParseStr(str);
    while aprinter.Canvas.TextWidth(str)>(ar^.RowWidth*aMMX) do
      str:=str[1..Length(str)-1];
    case ar^.TextAllign of
    TRCENTER:
      aprinter.Canvas.TextOut((((ar^.RowWidth*ammx)-aprinter.Canvas.TextWidth(str)) div 2)+(ar^.RowPos*ammx),
                              (_linepos){+(MargineTop*aMMY)},
                              str);
    TRLEFT:
      aprinter.Canvas.TextOut((MargineLeft*aMMx)+(ar^.RowPos*aMMX),
                              (_linepos){+(MargineTop*aMMY)},
                              str);
    TRRIGHT:
      aprinter.Canvas.TextOut((MargineLeft*aMMX)+(ar^.RowPos*ammX)+(ar^.RowWidth*ammx)-aprinter.Canvas.TextWidth(str),
                              (_linepos){+(MargineTop*aMMY)},
                              str);
    end;
    Inc(i);
    Inc(x);
    str:='';
  end;
end;

procedure TPDPrinter.WriteaTableX(s: string; aTable: PTableRows; aX: integer);
var str:string='';
    i:integer=1;
    x:integer=0;
    ar:PTableRow=nil;
begin
  while i<Length(s) do
  begin
    ar:=@aTable^[x];
    //Auszugebenen String zusammenknüpfen:
    While (s[i]<>'|') and (i<=Length(s)) do
    begin
      str:=str+s[i];
      Inc(i);
    end;
    str:=ParseStr(str);
    while aprinter.Canvas.TextWidth(str)>(ar^.RowWidth*aMMX) do
      str:=str[1..Length(str)-1];
    case ar^.TextAllign of
    TRCENTER:
      aprinter.Canvas.TextOut((((ar^.RowWidth*ammx)-aprinter.Canvas.TextWidth(str)) div 2)+(ar^.RowPos*ammx),
                              aX,
                              str);
    TRLEFT:
      aprinter.Canvas.TextOut((MargineLeft*aMMx)+(ar^.RowPos*aMMX),
                              aX,
                              str);
    TRRIGHT:
      aprinter.Canvas.TextOut((MargineLeft*aMMX)+(ar^.RowPos*ammX)+(ar^.RowWidth*ammx)-aprinter.Canvas.TextWidth(str),
                              aX,
                              str);
    end;
    Inc(i);
    Inc(x);
    str:='';
  end;
end;

procedure TPDPrinter.WriteHeader;
var tmpf:TFont;
begin
  // Font zwischen speichern
    tmpf:=TFont.Create;
    tmpf.Assign(aPrinter.Canvas.Font);
    // auf HeaderFont setzen
    aPrinter.Canvas.Font.Assign(aHeaderFont);
    SetLineSpacing(LineSpacing);
    // Header Drucken
    WriteaTable(aHeader,@aHeaderFormat);
    // Druckposition neu setzen
    _linepos:=_linepos+aLineSpacing;
    // alten Font wieder zurück setzen
    aPrinter.Canvas.Font.Assign(tmpf);
    SetLineSpacing(LineSpacing);
    tmpf.Free;
end;

function TPDPrinter.ParseStr(astr: string): string;
var ast:string;
begin
  ast:=StringReplace(astr,'{$PAGE}',inttostr(aPage),[rfReplaceAll]);
  ast:=StringReplace(ast, '{$LINE}',inttostr(aLine),[rfReplaceAll]);
  ast:=StringReplace(ast, '{$DATE}',FormatDateTime('dd.mm.yyyy',Date),[rfReplaceAll]);
  ast:=StringReplace(ast, '{$TIME}',FormatDateTime('hh:nn',Time),     [rfReplaceAll]);
  result:=ast;
end;

procedure TPDPrinter.WriteFooter;
var tmpf:TFont;
begin
  // Font zwischen speichern
    tmpf:=TFont.Create;
    tmpf.Assign(aPrinter.Canvas.Font);
    // auf HeaderFont setzen
    aPrinter.Canvas.Font.Assign(aFooterFont);
    SetLineSpacing(LineSpacing);
    // Header Drucken
    WriteaTableX(aFooter,@aFooterFormat,aPrinter.PageHeight-(MargineBottom*aMMY)-GetFooterHight);
    // Druckposition neu setzen
//    _linepos:=_linepos+aLineSpacing;
    // alten Font wieder zurück setzen
    aPrinter.Canvas.Font.Assign(tmpf);
    SetLineSpacing(LineSpacing);
    tmpf.Free;
end;

function TPDPrinter.GetFooterHight: integer;
var tmpf:TFont;
begin
  tmpf:=TFont.Create;
  tmpf.Assign(aPrinter.Canvas.Font);
  aPrinter.Canvas.Font.Assign(aFooterFont);
  result:=aPrinter.Canvas.TextHeight('M');
  aPrinter.Canvas.Font.Assign(tmpf);
  tmpf.Free;
end;

destructor TPDPrinter.Destroy;
begin
  inherited Destroy;
end;

procedure TPDPrinter.BeginDoc;
var tmp:TFont;
begin
  if Assigned(aOnBeginDoc) then aOnBeginDoc(Self);
  AdjustMM;
  tmp:=TFont.Create;
  tmp.Assign(aprinter.Canvas.Font);
  aPrinter.BeginDoc;
  aprinter.Canvas.Font.Assign(tmp);
  tmp.Free;
  aLine:=1;
  aPage:=1;
  SetLineSpacing(LineSpacing);
  _linepos:=(MargineTop*aMMY){-aLineSpacing};
  isHeader:=(aHeader<>'') and (Length(aHeaderFormat)>0);
  isFooter:=(aFooter<>'') and (Length(aFooterFormat)>0);
  if border then
  begin
    aprinter.Canvas.Brush.Color:=clwhite;
    aprinter.Canvas.Pen.Color:=clblack;
    aprinter.Canvas.Rectangle(0,0,aprinter.PageWidth,aprinter.PageHeight);
  end;
  if isHeader then
  begin
    WriteHeader;
  end;
end;

procedure TPDPrinter.EndDoc;
begin
  if Assigned(aOnEndDoc) then aOnEndDoc(Self);
  if isFooter then
    WriteFooter;
  aPrinter.EndDoc;
end;

procedure TPDPrinter.SetTableLineFormat(s: string);
begin
  SetTableFormat(s,@aTableRows);
end;

procedure TPDPrinter.SetHeaderFormat(s: string);
begin
  SetTableFormat(s,@aHeaderFormat);
end;

procedure TPDPrinter.SetFooterFormat(s: string);
begin
  SetTableFormat(s,@aFooterFormat);
end;

procedure TPDPrinter.WriteLine(s: string);
begin
  aprinter.Canvas.TextOut(MargineLeft*aMMx,(_linepos){+(MargineTop*aMMY)},s);
  NewLine;
end;

procedure TPDPrinter.WriteLineRight(s: string);
var xx:integer;
begin
  xx:=aprinter.PageWidth;
  aprinter.Canvas.TextOut(xx-((MargineRight*aMMx)+aprinter.Canvas.TextWidth(s)),
                          (_linepos){+(MargineTop*aMMY)},s);
  NewLine;
end;

procedure TPDPrinter.WritelineCenter(s: string);
var xx:integer;
begin
  xx:=aprinter.PageWidth;
  aprinter.Canvas.TextOut((xx-((MargineRight*aMMx)+aprinter.Canvas.TextWidth(s))) div 2,
                          (_linepos){+(MargineTop*aMMY)},s);
  NewLine;
end;

procedure TPDPrinter.WriteTableLine(s: string);
begin
  WriteaTable(s,@aTableRows);
  NewLine;
end;

procedure TPDPrinter.WritePos(s: string; X, Y: integer);
begin
  aPrinter.Canvas.TextOut(x,y,s);
end;

procedure TPDPrinter.NewLine;
var xx:integer=0;
begin
  if Assigned(aOnNewLine) then aOnNewLine(Self);
  if isFooter then
    xx:=GetFooterHight;
  Inc(aLine);
  SetLineSpacing(LineSpacing);
  _linepos:=_linepos+alinespacing;
  if _linepos{+(MargineTop*aMMY)}+(MargineBottom*aMMY)+alinespacing+xx>=aprinter.PageHeight then
    NewPage;
end;

procedure TPDPrinter.NewPage;
begin
  if Assigned(aOnNewPage) then aOnNewPage(Self);
  if isFooter then
    WriteFooter;
  aprinter.NewPage;
  aLine:=1;
  SetLineSpacing(LineSpacing);
  _Linepos:=(MargineTop*aMMY){-aLineSpacing};//aLineSpacing;
  if border then
  begin
    aprinter.Canvas.Brush.Color:=clwhite;
    aprinter.Canvas.Pen.Color:=clblack;
    aprinter.Canvas.Rectangle(0,0,aprinter.PageWidth,aprinter.PageHeight);
  end;
  Inc(aPage);
  if isHeader then
  begin
    WriteHeader;
  end;
end;

end.