pjstrings.pas

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

(*  GREATIS PRINT SUITE PRO                          *)
(*  unit version 1.85.012                            *)
(*  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 PJStrings;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  PSJob, Printers;

type

  TCustomStringsPrintJob = class(TCustomPrintJob)
  private
    { Private declarations }
    FStrings: TStrings;
    FFormattedStrings: TStrings;
    FFont: TFont;
    FLinesPerPage: Integer;
    FWordWrap: Boolean;
    FUseControlChars: Boolean;
    FOnUpdateProgress: TPSProgressEvent;
    procedure SetStrings(const Value: TStrings);
    procedure SetFont(const Value: TFont);
    procedure SetWordWrap(const Value: Boolean);
    procedure SetUseControlChars(const Value: Boolean);
    procedure FormatText(DC: HDC; Lines: TStrings; Width: Integer);
  protected
    { Protected declarations }
    property Strings: TStrings read FStrings write SetStrings;
    property Font: TFont read FFont write SetFont;
    property WordWrap: Boolean read FWordWrap write SetWordWrap default True;
    property UseControlChars: Boolean read FUseControlChars write SetUseControlChars default False;
    property OnUpdateProgress: TPSProgressEvent read FOnUpdateProgress write FOnUpdateProgress;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update; override;
    procedure DrawArea(TheCanvas: TCanvas; PageIndex: Integer; TheRect: TRect; Area: TDrawArea; Target: TDrawTarget); override;
  published
    { Published declarations }
  end;

  TStringsPrintJob = class(TCustomStringsPrintJob)
  published
    // TCustomStringsPrintJob properties
    property Strings;
    property Font;
    property WordWrap;
    property UseControlChars;
    property OnUpdateProgress;
    // TCustomPrintJob properties
    property MultiDoc;
    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 DefaultDrawing;
    property OnCreate;
    property OnDestroy;
    property OnDraw;
    property OnPrinterSetupChange;
    property OnStartPrint;
    property OnEndPrint;
    property OnPrintProgress;
    property OnStartPrintPage;
    property OnEndPrintPage;
    property OnUpdate;
  end;

procedure Register;

implementation

procedure TCustomStringsPrintJob.SetStrings(const Value: TStrings);
begin
  FStrings.Assign(Value);
  Update;
end;

procedure TCustomStringsPrintJob.SetFont(const Value: TFont);
begin
  FFont.Charset:=Value.Charset;
  FFont.Name:=Value.Name;
  FFont.Size:=Value.Size;
  FFont.Color:=Value.Color;
  FFont.Pitch:=Value.Pitch;
  FFont.Style:=Value.Style;
  Update;
end;

procedure TCustomStringsPrintJob.SetWordWrap(const Value: Boolean);
begin
  if Value<>FWordWrap then
  begin
    FWordWrap:=Value;
    Update;
  end;
end;

procedure TCustomStringsPrintJob.SetUseControlChars(const Value: Boolean);
begin
  if Value<>FUseControlChars then
  begin
    FUseControlChars:=Value;
    Update;
  end;
end;

procedure TCustomStringsPrintJob.FormatText(DC: HDC; Lines: TStrings; Width: Integer);

var
  S: string;
  L,I,B,T: Integer;
  R: TRect;

  function TextWidth(var S: string; L: Integer): Integer;
  var
    Size: TSize;
  begin
    if L=-1 then GetTextExtentPoint32(DC,PChar(S),Length(S),Size)
    else GetTextExtentPoint32(DC,PChar(S),L,Size);
    Result:=Size.CX;
  end;

  function DeleteChar(S: string; C: Char): string;
  var
    i: Integer;
  begin
    i:=1;
    while i<=Length(S) do
      if S[i]=C then Delete(S,i,1)
      else Inc(i);
    Result:=S;
  end;

begin
  T:=Lines.Count;
  L:=0;
  R:=Rect(0,0,Width,MaxInt);
  with Lines do
  begin
    while L<Count do
    begin
      S:=Lines[L];
      if TextWidth(S,-1)>Width then
      begin
        Lines.Delete(L);
        I:=1;
        B:=0;
        while I<=Length(S) do
        begin
          if not IsCharAlphaNumeric(S[I]) then B:=I;
          if TextWidth(S,I)>Width then
          begin
            if B<>0 then I:=Succ(B);
            Lines.Insert(L,Copy(S,1,Pred(I)));
            System.Delete(S,1,Pred(I));
            Inc(L);
            I:=1;
            B:=0;
          end
          else Inc(I);
        end;
        if S<>'' then
        begin
          Lines.Insert(L,S);
          Inc(L);
        end;
      end
      else
      begin
        Inc(L);
        if Assigned(FOnUpdateProgress) then
        try
          FOnUpdateProgress(Self,L,0,T);
        except
        end;
      end;
    end;
    if FUseControlChars then
    begin
      I:=0;
      while I<Count do
        if Pos(#12,Lines[I])>0 then
        begin
          Lines[I]:=DeleteChar(Lines[I],#12);
          for L:=Succ(I) mod FLinesPerPage to Pred(FLinesPerPage) do
            Lines.Insert(Succ(I),'');
          I:=Pred(Succ(I div FLinesPerPage)*FLinesPerPage);
        end
        else Inc(I);
    end;
  end;
end;

constructor TCustomStringsPrintJob.Create(AOwner: TComponent);
begin
  inherited;
  FStrings:=TStringList.Create;
  FFormattedStrings:=TStringList.Create;
  FFont:=TFont.Create;
  with FFont do
  begin
    Name:='Courier New';
    Size:=12;
  end;
  FWordWrap:=True;
end;

destructor TCustomStringsPrintJob.Destroy;
begin
  FStrings.Free;
  FFormattedStrings.Free;
  FFont.Free;
  inherited;
end;

procedure TCustomStringsPrintJob.Update;
var
  Canvas: TCanvas;
begin
  LockUpdate;
  try
    if PrinterOK and (Strings.Count>0) then
    begin
      Canvas:=TCanvas.Create;
      with FStrings,Canvas do
      try
        Handle:=CreateDC('DISPLAY',nil,nil,nil);
        Font.PixelsPerInch:=DPIY;
        Font.Assign(FFont);
        FFormattedStrings.Assign(FStrings);
        with GetPageRect do
          FLinesPerPage:=(Bottom-Top) div TextHeight(' ');
        if FWordWrap or FUseControlChars then
          with GetPageRect do FormatText(Handle,FFormattedStrings,Right-Left);
        PageCount:=
          FFormattedStrings.Count div FLinesPerPage+
          Integer(FFormattedStrings.Count mod FLinesPerPage<>0);
      finally
        Free;
      end;
    end
    else PageCount:=1;
  finally
    UnlockUpdate;
  end;
  inherited;
end;

procedure TCustomStringsPrintJob.DrawArea(TheCanvas: TCanvas; PageIndex: Integer;
  TheRect: TRect; Area: TDrawArea; Target: TDrawTarget);
var
  i: Integer;
  R: TRect;
begin
  with TheCanvas do
  begin
    Font.Assign(FFont);
    Brush.Style:=bsClear;
    if Area=daPage then
    begin
      if FFormattedStrings.Count>0 then
      begin
        for i:=Pred(PageIndex)*FLinesPerPage to Pred(PageIndex*FLinesPerPage) do
        begin
          if i>Pred(FFormattedStrings.Count) then Break;
          R:=TheRect;
          with TheRect do
          begin
            R.Top:=Top+(i mod FLinesPerPage)*(Bottom-Top) div FLinesPerPage;
            DrawTabbedText(TheCanvas,R.Left,R.Top,FFormattedStrings[i]);
          end;
        end;
      end;
    end
    else inherited;
  end;
end;

procedure Register;
begin
  RegisterComponents('Print Jobs', [TStringsPrintJob]);
end;

end.