preport.pas

作者:Takeshi Kanno. PowerPdf是一款制作PDF文档的VCL控件。使用上和QuickReport类似。

{*
 * << P o w e r P d f >> -- PReport.pas
 *
 * Copyright (c) 1999-2001 Takezou. <[e-mail]>
 *
 * This library is free software; you can redistribute it and/or modify it
 * under the terms of the GNU Library General Public License as published
 * by the Free Software Foundation; either version 2 of the License, or any
 * later version.
 *
 * This library is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
 * FOR A PARTICULAR PURPOSE. See the GNU Library general Public License for more
 * details.
 *
 * You should have received a copy of the GNU Library General Public License
 * along with this library.
 *
 * Create 2001.01.28
 *
 *}
unit PReport;

interface

//{$DEFINE USE_JPFONTS}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, PdfDoc, PdfFonts, PdfTypes, PdfImages
  {$IFNDEF USE_JPFONTS}
  ;
  {$ELSE}
  , PdfJPFonts;
  {$ENDIF}

const
  POWER_PDF_VERSION_STR = 'PowerPdf 0.8(beta)';
  POWER_PDF_COPYRIGHT = 'copyright (c) 1999-2001 takeshi kanno';

type
  TPRFontName = (fnFixedWidth
               , fnArial
               , fnTimesRoman
               {$IFDEF USE_JPFONTS}
               , fnGothic
               , fnMincyo
               , fnPGothic
               , fnPMincyo
               {$ENDIF}
               );
  TPRPage = class;
  TPRCanvas = class;
  TPRPanel = class;
  TPRItem = class;

  TPRPrintPageEvent = procedure(Sender: TObject;
                              ACanvas: TPRCanvas) of object;
  TPRPrintPanelEvent = procedure(Sender: TObject; ACanvas: TPRCanvas;
                              Rect: TRect) of object;
  TPRPrintItemEvent = TPRPrintPanelEvent;
  TPRPrintChildPanelEvent = procedure(Sender: TObject; ACanvas: TPRCanvas;
                              ACol, ARow: integer; Rect: TRect) of object;
  TPrintDirection = (pdHolz, pdVert);

  { TPReport }
  TPReport = class(TComponent)
  private
    FFileName: string;
    FPage: integer;
    FAuthor: string;
    FCreationDate: TDateTime;
    FCreator: string;
    FKeywords: string;
    FModDate: TDateTime;
    FSubject: string;
    FTitle: string;
    FCanvas: TPRCanvas;
    FDoc: TPdfDoc;
    FPageMode: TPdfPageMode;
    FCompressionMethod: TPdfCompressionMethod;
  protected
    { Protected }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BeginDoc;
    procedure Print(APage: TPRPage);
    procedure EndDoc;
    procedure Abort;
    function GetPdfDoc: TPdfDoc;
    property PageNumber: integer read FPage;
  published
    property FileName: string read FFileName write FFileName;
    property Author: string read FAuthor write FAuthor;
    property CreationDate: TDateTime read FCreationDate write FCreationDate;
    property Creator: string read FCreator write FCreator;
    property Keywords: string read FKeyWords write FKeyWords;
    property ModDate: TDateTime read FModDate write FModDate;
    property Subject: string read FSubject write FSubject;
    property Title: string read FTitle write FTitle;
    property PageMode: TPdfPageMode read FPageMode write FPageMode;
    property CompressionMethod: TPdfCompressionMethod
       read FCompressionMethod write FCompressionMethod;
  end;

  { TPRCanvas }
  TPRCanvas = class(TPersistent)
  private
    FCanvas: TPdfCanvas;
    procedure SetPdfCanvas(ACanvas: TPdfCanvas);
  protected
    property PdfCanvas: TPdfCanvas read FCanvas write SetPdfCanvas;
  public
    constructor Create;
    procedure SetCharSpace(charSpace: Single);
    procedure SetWordSpace(wordSpace: Single);
    procedure SetHorizontalScaling(hScaling: Word);
    procedure SetLeading(leading: Single);
    procedure SetFontAndSize(fontname: string; size: Single);
    procedure SetTextRenderingMode(mode: TTextRenderingMode);
    procedure SetTextRise(rise: Word);
  end;

  { TPRPage }
  TPRPage = class(TCustompanel)
  private
    FDoc: TPdfDoc;
    FMarginTop: integer;
    FMarginLeft: integer;
    FMarginRight: integer;
    FMarginBottom: integer;
    FPrintPageEvent: TPRPrintPageEvent;
    procedure SetMarginTop(Value: integer);
    procedure SetMarginLeft(Value: integer);
    procedure SetMarginRight(Value: integer);
    procedure SetMarginBottom(Value: integer);
  protected
    procedure AlignControls(AControl: TControl; var ARect: TRect); override;
    procedure Paint; override;
    procedure Print(ACanvas: TPRCanvas);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnPrintPage: TPRPrintPageEvent
                     read FPrintPageEvent write FPrintPageEvent;
    property MarginTop: integer read FMarginTop write SetMarginTop;
    property MarginLeft: integer read FMarginLeft write SetMarginLeft;
    property MarginRight: integer read FMarginRight write SetMarginRight;
    property MarginBottom: integer read FMarginBottom write SetMarginBottom;
    property Visible;
  end;

  { TPRPanel }
  TPRPanel = class(TCustomPanel)
  private
    function GetPage: TPRPage;
    function GetAbsoluteRect: TRect;
  protected
    procedure Paint; override;
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); virtual;
  public
    property Page: TPRPage read GetPage;
    constructor Create(AOwner: TComponent); override;
  end;

  { TPRChildPanel }
  TPRChildPanel = class(TPRPanel)
  private
  protected
  end;

  { TPRLayoutPanel }
  TPRLayoutPanel = class(TPRPanel)
  private
    FAfterPrint: TPRPrintPanelEvent;
    FBeforePrint: TPRPrintPanelEvent;
  protected
    procedure SetParent(AParent: TWinControl); override;
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  published
    property Align;
    property BeforePrint: TPRPrintPanelEvent
                                read FBeforePrint write FBeforePrint;
    property AfterPrint: TPRPrintPanelEvent
                                read FAfterPrint write FAfterPrint;
  end;

  { TRRGridPanel }
  TPRGridPanel = class(TPRPanel)
  private
    FAfterPrint: TPRPrintPanelEvent;
    FBeforePrint: TPRPrintPanelEvent;
    FBeforePrintChild: TPRPrintChildPanelEvent;
    FAfterPrintChild: TPRPrintChildPanelEvent;
    FColCount: integer;
    FRowCount: integer;
    FChildPanel: TPRChildPanel;
    FPrintDirection: TPrintDirection;
    procedure SetColCount(Value: integer);
    procedure SetRowCount(Value: integer);
  protected
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure AlignControls(AControl: TControl; var ARect: TRect); override;
    procedure Paint; override;
    procedure SetParent(AParent: TWinControl); override;
    function GetChildParent: TComponent; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ColCount: integer read FColCount write SetColCount;
    property RowCount: integer read FRowCount write SetRowCount;
    property Align;
    property PrintDirection: TPrintDirection
                        read FPrintDirection write FPrintDirection;
    property BeforePrint: TPRPrintPanelEvent
                        read FBeforePrint write FBeforePrint;
    property AfterPrint: TPRPrintPanelEvent
                        read FAfterPrint write FAfterPrint;
    property BeforePrintChild: TPRPrintChildPanelEvent
                        read FBeforePrintChild write FBeforePrintChild;
    property AfterPrintChild: TPRPrintChildPanelEvent
                        read FAfterPrintChild write FAfterPrintChild;
  end;

  { TPRItem }
  TPRItem = class(TGraphicControl)
  private
    FPrintable: boolean;
    function GetPage: TPRPage;
  protected
    procedure SetParent(AParent: TWinControl); override;
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); virtual;
    property Page: TPRPage read GetPage;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property Printable: boolean read FPrintable write FPrintable;
  end;

  { TPRText }
  TPRText = class(TPRItem)
  private
    FFontColor: TColor;
    FFontName: TPRFontName;
    FFontSize: Single;
    FFontBold: boolean;
    FFontItalic: boolean;
    FCharSpace: Single;
    FWordSpace: Single;
    FWordwrap: boolean;
    FLeading: Single;
    FLines: TStrings;
    procedure SetLeading(Value: Single);
    procedure SetCharSpace(Value: Single);
    procedure SetWordSpace(Value: Single);
    procedure SetWordwrap(Value: boolean);
    procedure SetFontColor(Value: TColor);
    procedure SetLines(Value: TStrings);
    procedure SetText(Value: string);
    function GetText: string;
    function GetLines: TStrings;
    function GetFontClassName: string;
    procedure SetFontName(Value: TPRFontName);
    procedure SetFontItalic(Value: boolean);
    procedure SetFontBold(Value: boolean);
    procedure SetFontSize(Value: Single);
    function InternalTextout(APdfCanvas: TPdfCanvas;
                        S: string; X, Y: integer): Single;
    function GetNextWord(const S: string; var Index: integer): string;
  protected
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure Paint; override;
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
    function GetInternalDoc: TPdfDoc;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text: string read GetText write SetText;
  published
    property FontColor: TColor read FFontColor write SetFontColor default clBlack;
    property FontName: TPRFontName read FFontName write SetFontName;
    property FontSize: Single read FFontSize write SetFontSize;
    property FontBold: boolean read FFontBold write SetFontBold default false;
    property FontItalic: boolean read FFontItalic write SetFontItalic default false;
    property CharSpace: Single read FCharSpace write SetCharSpace;
    property Leading: Single read FLeading write SetLeading;
    property Lines: TStrings read GetLines write SetLines;
    property WordSpace: Single read FWordSpace write SetWordSpace;
    property WordWrap: boolean read FWordWrap write SetWordwrap default false;
  end;

  { TPRRect }
  TPRRect = class(TPRItem)
  private
    FLineWidth: Single;
    FLineColor: TColor;
    FLineStyle: TPenStyle;
    FFillColor: TColor;
    procedure SetLineColor(Value: TColor);
    procedure SetFillColor(Value: TColor);
    procedure SetLineWidth(Value: Single);
    procedure SetLineStyle(Value: TPenStyle);
  protected
    procedure Paint; override;
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property LineWidth: Single read FLineWidth write SetLineWidth;
    property LineColor: TColor read FLineColor write SetLineColor default clBlack;
    property LineStyle: TPenStyle read FLineStyle write SetLineStyle;
    property FillColor: TColor read FFillColor write SetFillColor default clNone;
  end;

  { TPRImage }
  TPRImage = class(TPRItem)
  private
    FPicture: TPicture;
    FSharedImage: boolean;
    procedure SetPicture(Value: TPicture);
  protected
    procedure Paint; override;
    procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Picture: TPicture read FPicture write SetPicture;
    property SharedImage: boolean read FSharedImage write FSharedImage;
  end;

procedure Register;

implementation

const
  LINE_PITCH: integer = 378;
  LINE_COLOR: TColor = clSilver;
  DEFAULT_MARGIN = 32;
  PROTECT_AREA_COLOR: TColor = $00EFEFEF;
  MIN_PANEL_SIZE = 10;
  MAX_IMAGE_NUMBER = 65535;
{$IFDEF USE_JPFONTS}
  PDFFONT_CLASS_NAMES: array[0..6] of string = (
                           'FixedWidth',
                           'Arial',
                           'Times-Roman',
                           'Gothic',
                           'Mincyo',
                           'PGothic',
                           'PMincyo');
  PDFFONT_CLASS_BOLD_NAMES: array[0..6] of string = (
                           'FixedWidth-Bold',
                           'Arial-Bold',
                           'Times-Bold',
                           'Gothic,Bold',
                           'Mincyo,Bold',
                           'PGothic,Bold',
                           'PMincyo,Bold');
  PDFFONT_CLASS_ITALIC_NAMES: array[0..6] of string = (
                           'FixedWidth-Italic',
                           'Arial-Italic',
                           'Times-Italic',
                           'Gothic,Italic',
                           'Mincyo,Italic',
                           'PGothic,Italic',
                           'PMincyo,Italic');
  PDFFONT_CLASS_BOLDITALIC_NAMES: array[0..6] of string = (
                           'FixedWidth-BoldItalic',
                           'Arial-BoldItalic',
                           'Times-BoldItalic',
                           'Gothic,BoldItalic',
                           'Mincyo,BoldItalic',
                           'PGothic,BoldItalic',
                           'PMincyo');
  ITEM_FONT_NAMES: array[0..6] of string = (
                           'Courier New',
                           'Arial',
                           'Century',
                           #130#108#130#114#32#131#83#131#86#131#98#131#78,
                           #130#108#130#114#32#150#190#146#169,
                           #130#108#130#114#32#130#111#131#83#131#86#131#98#131#78,
                           #130#108#130#114#32#130#111#150#190#146#169);
  ITEM_FONT_CHARSETS: array[0..6] of TFontCharset = (
                           ANSI_CHARSET,
                           ANSI_CHARSET,
                           ANSI_CHARSET,
                           SHIFTJIS_CHARSET,
                           SHIFTJIS_CHARSET,
                           SHIFTJIS_CHARSET,
                           SHIFTJIS_CHARSET);
{$ELSE}
  PDFFONT_CLASS_NAMES: array[0..2] of string = (
                           'FixedWidth',
                           'Arial',
                           'Times-Roman');
  PDFFONT_CLASS_BOLD_NAMES: array[0..2] of string = (
                           'FixedWidth-Bold',
                           'Arial-Bold',
                           'Times-Bold');
  PDFFONT_CLASS_ITALIC_NAMES: array[0..2] of string = (
                           'FixedWidth-Italic',
                           'Arial-Italic',
                           'Times-Italic');
  PDFFONT_CLASS_BOLDITALIC_NAMES: array[0..2] of string = (
                           'FixedWidth-BoldItalic',
                           'Arial-BoldItalic',
                           'Times-BoldItalic');
  ITEM_FONT_NAMES: array[0..2] of string = (
                           'Courier New',
                           'Arial',
                           'TimesNewRoman');
  ITEM_FONT_CHARSETS: array[0..2] of TFontCharset = (
                           ANSI_CHARSET,
                           ANSI_CHARSET,
                           ANSI_CHARSET);
{$ENDIF}

{ common routines }

procedure PaintGrid(Canvas: TCanvas; Width, Height: integer;
  OffsetX, OffsetY: integer);
var
  LinePos: integer;
  LineCount: integer;
  LineFlg: boolean;

  // sub routine to set pen style
  procedure SetPen(Canvas: TCanvas; flg: boolean);
  begin
    Canvas.Pen.Color := LINE_COLOR;
    if flg then
      Canvas.Pen.Style := psSolid
    else
      Canvas.Pen.Style := psDot;
  end;

begin
  with Canvas do
  begin
    // drawing vertical lines.
    LineCount := 0;
    LineFlg := true;
    LinePos := - OffsetX;
    while LinePos < Width do
    begin
      if LinePos > 0 then
      begin
        MoveTo(LinePos, 0);
        SetPen(Canvas, LineFlg);
        LineTo(LinePos, Height - 1);
      end;
      inc(LineCount);
      LineFlg := not LineFlg;
      LinePos := trunc(LineCount * LINE_PITCH / 20) - OffsetX;
    end;

    // drawing horizontal lines.
    LineCount := 0;
    LineFlg := true;
    LinePos := - OffsetY;
    while LinePos < Height do
    begin
      if LinePos > 0 then
      begin
        MoveTo(0, LinePos);
        SetPen(Canvas, LineFlg);
        LineTo(Width - 1, LinePos);
      end;
      inc(LineCount);
      LineFlg := not LineFlg;
      LinePos := trunc(LineCount * LINE_PITCH / 20) - OffsetY;
    end;
  end;
end;

{ TPReport }

// Create
constructor TPReport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFileName := 'default.pdf';
  FCreationDate := now;
  FDoc := nil;
  FCanvas := TPRCanvas.Create;
end;

// Destroy
destructor TPReport.Destroy;
begin
  FCanvas.Free;
  if FDoc <> nil then Abort;
  inherited;
end;

// BeginDoc
procedure TPReport.BeginDoc;
begin
  if FDoc <> nil then Abort;
  FDoc := TPdfDoc.Create(Self);
  with FDoc do
  begin
    CompressionMethod := FCompressionMethod;
    NewDoc;
    Root.PageMode := PageMode;
    Info.Author := Author;
    Info.CreationDate := CreationDate;
    Info.Creator := Creator;
    Info.Keywords := Keywords;
    Info.ModDate := ModDate;
    Info.Subject := Subject;
    Info.Title := Title;
  end;
  FPage := 0;
end;

// Print
procedure TPReport.Print(APage: TPRPage);
begin
  FDoc.AddPage;
  inc(FPage);
  FCanvas.PdfCanvas := FDoc.Canvas;
  APage.Print(FCanvas);
end;

// EndDoc
procedure TPReport.EndDoc;
var
  FStream: TStream;
begin
  if FDoc <> nil then
  begin
    FStream := TFileStream.Create(FFileName, fmCreate);
    FDoc.SaveToStream(FStream);
    FStream.Free;
    FDoc.Free;
    FDoc := nil;
  end
  else
    raise EInvalidOperation.Create('document is null..');
end;

// Abort
procedure TPReport.Abort;
begin
  if FDoc <> nil then
  begin
    FDoc.Free;
    FDoc := nil;
  end
end;

// GetPdfDoc
function TPReport.GetPdfDoc: TPdfDoc;
begin
  result := FDoc;
end;

{ TPRCanvas }

// Create
constructor TPRCanvas.Create;
begin
  inherited;
  FCanvas := nil;
end;

// SetPdfCanvas
procedure TPRCanvas.SetPdfCanvas(ACanvas: TPdfCanvas);
begin
  FCanvas := ACanvas;
end;

procedure TPRCanvas.SetCharSpace(charSpace: Single);
begin
  PdfCanvas.SetCharSpace(charSpace);
end;

procedure TPRCanvas.SetWordSpace(wordSpace: Single);
begin
  PdfCanvas.SetWordSpace(wordSpace);