pdfdoc.pas

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

{*
 * << P o w e r P d f >> -- PdfDoc.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 2000.09.10
 *
 *}
unit PdfDoc;

interface

//{DEFINE NOIMAGE}

// if use "FlateDecode" compression, comment out the next line.
// (this unit and PdfTypes.pas)
{$DEFINE NOZLIB}

uses
  SysUtils, Classes, PdfTypes, Dialogs
  {$IFNDEF NOIMAGE}
  , Graphics
  {$ENDIF}
  ;

type
  {*
   * The pagemode determines how the document should appear when opened.
   *}
  TPdfPageMode = (pmUseNone,
                  pmUseOutlines,
                  pmUseThumbs,
                  pmFullScreen);

  {*
   * The line cap style specifies the shape to be used at the ends of open
   * subpaths when they are stroked.
   *}
  TLineCapStyle = (lcButt_End,
                   lcRound_End,
                   lcProjectingSquareEnd);

  {*
   * The line join style specifies the shape to be used at the corners of paths
   * that are stroked.
   *}
  TLineJoinStyle = (ljMiterJoin,
                    ljRoundJoin,
                    ljBevelJoin);

  {*
   * The text rendering mode determines whether text is stroked, filled, or used
   * as a clipping path.
   *}
  TTextRenderingMode = (trFill,
                        trStroke,
                        trFillThenStroke,
                        trInvisible,
                        trFillClipping,
                        trStrokeClipping,
                        trFillStrokeClipping,
                        trClipping);

  TPdfHeader = class(TObject)
  protected
    procedure WriteToStream(const AStream: TStream);
  end;

  TPdfTrailer = class(TObject)
  private
    FAttributes: TPdfDictionary;
    FXrefAddress: integer;
  protected
    procedure WriteToStream(const AStream: TStream);
  public
    constructor Create(AObjectMgr: TPdfObjectMgr);
    destructor Destroy; override;
    property XrefAddress: integer read FXrefAddress write FXrefAddress;
    property Attributes: TPdfDictionary read FAttributes;
  end;

  TPdfXrefEntry = class(TObject)
  private
    FEntryType: string;
    FByteOffset: integer;
    FGenerationNumber: integer;
    FValue: TPdfObject;
    function GetAsString: string;
  public
    constructor Create(AValue: TPdfObject);
    destructor Destroy; override;
    property EntryType: string read FEntryType write FEntryType;
    property ByteOffset: integer read FByteOffSet write FByteOffset;
    property GenerationNumber: integer
                          read FGenerationNumber write FGenerationNumber;
    property AsString: string read GetAsString;
    property Value: TPdfObject read FValue;
  end;

  TPdfXref = class(TPdfObjectMgr)
  private
    FXrefEntries: TList;
    function GetItem(ObjectID: integer): TPdfXrefEntry;
    function GetItemCount: integer;
  protected
    procedure WriteToStream(const AStream: TStream);
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddObject(AObject: TPdfObject); override;
    function GetObject(ObjectID: integer): TPdfObject; override;
    property Items[ObjectID: integer]: TPdfXrefEntry read GetItem;
    property ItemCount: integer read GetItemCount;
  end;

  TPdfCanvas = class;
  TXObjectID = integer;
  TPdfInfo = class;
  TPdfCatalog = class;
  TPdfFont = class;

  {$IFDEF NOZLIB}
  TPdfCompressionMethod = (cmNone);
  {$ELSE}
  TPdfCompressionMethod = (cmNone, cmFlateDecode);
  {$ENDIF}

  TPdfDoc = class(TComponent)
  private
    FRoot: TPdfCatalog;
    FCurrentPages: TPdfDictionary;
    FCanvas: TPdfCanvas;
    FHeader: TPdfHeader;
    FTrailer: TPdfTrailer;
    FXref: TPdfXref;
    FInfo: TPdfInfo;
    FHasDoc: boolean;
    FFontList: TList;
    FXObjectList: TPdfArray;
    FDefaultPageWidth: Word;
    FDefaultPageHeight: Word;
    FCompressionMethod: TPdfCompressionMethod;
    function GetCanvas: TPdfCanvas;
    function GetInfo: TPdfInfo;
    function GetRoot: TPdfCatalog;
  protected
    procedure CreateInfo;
    function CreateCatalog: TPdfDictionary;
    function CreateFont(FontName: string): TPdfFont;
    function CreatePages(Parent: TPdfDictionary): TPdfDictionary;
  public
    procedure RegisterXObject(AObject: TPdfXObject; AName: string);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure NewDoc;
    procedure FreeDoc;
    procedure AddPage;
    {$IFNDEF NOIMAGE}
    procedure AddImage(AName: string; AImage: TGraphic; ImageClassName: string);
    {$ENDIF}
    procedure SaveToStream(AStream: TStream);
    function GetFont(FontName: string): TPdfFont;
    function GetXObject(AName: string): TPdfXObject;
    function AddOutlineEntry(AParent: TPdfOutlineEntry; ATitle: string;
      AXPos, AYPos: Single; AOpened: boolean): TPdfOutlineEntry;
    property HasDoc: boolean read FHasDoc;
    property Canvas: TPdfCanvas read GetCanvas;
    property Info: TPdfInfo read GetInfo;
    property Root: TPdfCatalog read GetRoot;
  published
    property DefaultPageWidth: word read FDefaultPageWidth write FDefaultPageWidth;
    property DefaultPageHeight: word read FDefaultPageHeight write FDefaultPageHeight;
    property CompressionMethod: TPdfCompressionMethod
       read FCompressionMethod write FCompressionMethod;
  end;

  TPdfCanvasAttribute = class(TObject)
  private
    FWordSpace: Single;
    FCharSpace: Single;
    FFontSize: Single;
    FFont: TPdfFont;
    FHorizontalScaling: Word;
    procedure SetWordSpace(Value: Single);
    procedure SetCharSpace(Value: Single);
    procedure SetFontSize(Value: Single);
    procedure SetHorizontalScaling(Value: Word);
    procedure SetFont(Value: TPdfFont);
  public
    function TextWidth(Text: string): Single;
    function MesureText(Text: string; Width: Single): integer;
    property WordSpace: Single read FWordSpace write SetWordSpace;
    property CharSpace: Single read FCharSpace write SetCharSpace;
    property HorizontalScaling: Word read FHorizontalScaling
      write SetHorizontalScaling;
    property FontSize: Single read FFontSize write SetFontSize;
    property Font: TPdfFont read FFont write SetFont;
  end;

  TPdfCanvas = class(TObject)
  private
    FContents: TPdfStream;
    FPage: TPdfDictionary;
    FPdfDoc: TPdfDoc;
    FAttr: TPdfCanvasAttribute;
    procedure SetPageWidth(AValue: integer);
    procedure SetPageHeight(AValue: integer);
    function GetPageWidth: Integer;
    function GetPageHeight: Integer;
    function GetColorStr(Color: TColor): string;
  protected
  public
    constructor Create(APdfDoc: TPdfDoc);
    destructor Destroy; override;

    {* Special Graphics State *}
    procedure GSave;                                             {  q   }
    procedure GRestore;                                          {  Q   }
    procedure Concat(a, b, c, d, e, f: Single);                  {  cm  }

    {* General Graphics State *}
    procedure SetFlat(flatness: Byte);                           {  i   }
    procedure SetLineCap(linecap: TLineCapStyle);                {  J   }
    procedure SetDash(aarray: array of Byte; phase: Byte);       {  d   }
    procedure SetLineJoin(linejoin: TLineJoinStyle);             {  j   }
    procedure SetLineWidth(linewidth: Single);                   {  w   }
    procedure SetMiterLimit(miterlimit: Byte);                   {  M   }

    {* Paths *}
    procedure MoveTo(x, y: Word);                                {  m   }
    procedure LineTo(x, y: Word);                                {  l   }
    procedure CurveToC(x1, y1, x2, y2, x3, y3: Word);            {  c   }
    procedure CurveToV(x2, y2, x3, y3: Word);                    {  v   }
    procedure CurveToY(x1, y1, x3, y3: Word);                    {  y   }
    procedure Rectangle(x, y, width, height: Word);              {  re  }
    procedure Closepath;                                         {  h   }
    procedure NewPath;                                           {  n   }
    procedure Stroke;                                            {  S   }
    procedure ClosePathStroke;                                   {  s   }
    procedure Fill;                                              {  f   }
    procedure Eofill;                                            {  f*  }
    procedure FillStroke;                                        {  B   }
    procedure ClosepathFillStroke;                               {  b   }
    procedure EofillStroke;                                      {  B*  }
    procedure ClosepathEofillStroke;                             {  b*  }
    procedure Clip;                                              {  W   }
    procedure Eoclip;                                            {  W*  }

    {* Test state *}
    procedure SetCharSpace(charSpace: Single);                   {  Tc  }
    procedure SetWordSpace(wordSpace: Single);                   {  Tw  }
    procedure SetHorizontalScaling(hScaling: Word);              {  Tz  }
    procedure SetLeading(leading: Single);                       {  TL  }
    procedure SetFontAndSize(fontname: string; size: Single);    {  Tf  }
    procedure SetTextRenderingMode(mode: TTextRenderingMode);    {  Tr  }
    procedure SetTextRise(rise: Word);                           {  Ts  }
    procedure BeginText;                                         {  BT  }
    procedure EndText;                                           {  ET  }
    procedure MoveTextPoint(tx, ty: Word);                       {  Td  }
    procedure SetTextMatrix(a, b, c, d, x, y: Word);             {  Tm  }
    procedure MoveToNextLine;                                    {  T*  }
    procedure ShowText(s: string);                               {  Tj  }
    procedure ShowTextNextLine(s: string);                       {  '   }

    {* external objects *}
    procedure ExecuteXObject(xObject: string);                   {  Do  }

    {* Device-dependent color space operators *}
    procedure SetRGBFillColor(Value: TColor);                    {  rg  }
    procedure SetRGBStrokeColor(Value: TColor);                  {  RG  }

    procedure SetPage(APage: TPdfDictionary);
    procedure SetFont(AName: string; ASize: Single);
    procedure DrawXObject(X, Y, AWidth, AHeight: Single;
       AXObjectName: string);
    function TextWidth(Text: string): Single;
    function MesureText(Text: string; AWidth: Single): integer;
    function GetDoc: TPdfDoc;

    property Attribute: TPdfCanvasAttribute read FAttr;
    property Contents: TPdfStream read FContents;
    property Page: TPdfDictionary read FPage;
    property PageWidth: integer read GetPageWidth write SetPageWidth;
    property PageHeight: integer read GetPageHeight write SetPageHeight;
  end;

  TPdfDictionaryWrapper = class(TPersistent)
  private
    FData: TPdfDictionary;
    function GetHasData: boolean;
  protected
    procedure SetData(AData: TPdfDictionary); virtual;
    property Data: TPdfDictionary read FData write SetData;
    property HasData: boolean read GetHasData;
  end;

  TPdfInfo = class(TPdfDictionaryWrapper)
  private
    function GetAuthor: string;
    procedure SetAuthor(Value: string);
    function GetCreationDate: TDateTime;
    procedure SetCreationDate(Value: TDateTime);
    function GetCreator: string;
    procedure SetCreator(Value: string);
    function GetKeywords: string;
    procedure SetKeywords(Value: string);
    function GetSubject: string;
    procedure SetSubject(Value: string);
    function GetTitle: string;
    procedure SetTitle(Value: string);
    function GetModDate: TDateTime;
    procedure SetModDate(Value: TDateTime);
  public
    property Author: string read GetAuthor write SetAuthor;
    property CreationDate: TDateTime read GetCreationDate write SetCreationDate;
    property Creator: string read GetCreator write SetCreator;
    property Keywords: string read GetKeywords write SetKeywords;
    property ModDate: TDateTime read GetModDate write SetModDate;
    property Subject: string read GetSubject write SetSubject;
    property Title: string read GetTitle write SetTitle;
  end;

  TPdfCatalog = class(TPdfDictionaryWrapper)
  private
    FOutlines: TPdfDictionary;
    FPages: TPdfDictionary;
    procedure SetPageMode(Value: TPdfPageMode);
    procedure SetUseOutlines(Value: boolean);
    procedure SetPages(APage: TPdfDictionary);
    function GetPageMode: TPdfPageMode;
    function GetUseOutlines: boolean;
    function GetOutlines: TPdfDictionary;
    function GetPages: TPdfDictionary;
  protected
    procedure CreateOutlines;
  public
    property UseOutlines: boolean read GetUseOutlines write SetUseOutlines;
    property PageMode: TPdfPageMode read GetPageMode write SetPageMode;
    property Outlines: TPdfDictionary read GetOutlines;
    property Pages: TPdfDictionary read GetPages write SetPages;
  end;

  TPDF_STR_TBL = record
    KEY: string;
    VAL: string;
  end;
  TPDF_INT_TBL = record
    KEY: string;
    VAL: integer;
  end;

  TPdfFont = class(TPdfDictionaryWrapper)
  private
    FName: string;
  protected
    procedure AddStrElements(ADic: TPdfDictionary; ATable: array of TPDF_STR_TBL);
    procedure AddIntElements(ADic: TPdfDictionary; ATable: array of TPDF_INT_TBL);
  public
    constructor Create(AXref: TPdfXref; AName: string); virtual;
    function GetCharWidth(AText: string; APos: integer): integer; virtual;
    property Name: string read FName;
  end;

  {$IFNDEF NOIMAGE}
  TPdfImageCreator = class(TPersistent)
  public
    function CreateImage(AXref: TPdfXref; AImage: TGraphic): TPdfXObject; virtual;
    constructor Create;
  end;
  {$ENDIF}

implementation

const
  PDF_PAGE_MODE_NAMES: array[0..3] of string = ('UseNone',
                                              'UseOutlines',
                                              'UseThumbs',
                                              'FullScreen');

{ Utility functions }

procedure _Pages_AddKids(AParent: TPdfDictionary; AKid: TPdfDictionary);
var
  FKids: TPdfArray;
begin
  // adding page object to the parent pages object.
  FKids := AParent.PdfArrayByName('Kids');
  FKids.AddItem(AKid);
  AParent.PdfNumberByName('Count').Value := FKids.ItemCount;
end;

function _Page_GetResources(APage: TPdfDictionary; AName: string): TPdfDictionary;
var
  FResources: TPdfDictionary;
begin
  FResources := APage.PdfDictionaryByName('Resources');
  result := FResources.PdfDictionaryByName(AName);
end;

procedure _OutlineEntry_AddChild(AParent: TPdfDictionary;
  AEntry: TPdfOutlineEntry; AOpened: integer);
var
  OldLastEntry: TPdfOutlineEntry;

  procedure IncCount(AEntry: TPdfDictionary);
  var
    TmpEntry: TPdfDictionary;
    FCountObj: TPdfNumber;
    FOpenObj: TPdfNumber;
    FChildCount: integer;
  begin
    // calculate new chiledren count. if zero (and has children means outlines
    // is closed) then do nothing.
    TmpEntry := AEntry;
    while TmpEntry <> nil do
    begin
      with TmpEntry do
      begin
        // get count attribute from parent entry, if null then create.
        FCountObj := PdfNumberByName('Count');
        if FCountObj = nil then
        begin
          FCountObj := TPdfNumber.CreateNumber(0);
          AddItem('Count', FCountObj);
        end;

        // get open (internal) attribute from parent entry, if null then create.
        FOpenObj := PdfNumberByName('Opened');
        if FOpenObj = nil then
        begin
          if FCountObj.Value > 0 then
            FOpenObj := TPdfNumber.CreateNumber(PDF_ENTRY_OPENED)
          else
            FOpenObj := TPdfNumber.CreateNumber(PDF_ENTRY_CLOSED);
          AddInternalItem('Opened', FOpenObj);
        end;
        FChildCount := Abs(FCountObj.Value);
        inc(FChildCount);
        if FOpenObj.Value = PDF_ENTRY_OPENED then
          FCountObj.Value := FChildCount
        else
          FCountObj.Value := -FChildCount;
      end;
      TmpEntry := TmpEntry.PdfDictionaryByName('Parent');
    end;
  end;
begin