frxpdffile.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{                                          }
{             FastReport v3.0              }
{             PDF file library             }
{                                          }
{         Copyright (c) 1998-2005          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}

unit frxPDFFile;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Forms,
  ComObj, ComCtrls, frxClass, JPEG
{$IFDEF Delphi6}, Variants {$ENDIF};

type
  TfrxPDFPage = class;
  TfrxPDFFont = class;

  TfrxPDFElement = class(TObject)
  private
    FXrefPosition: Cardinal;
    FIndex: Integer;
  public
    constructor Create;
    procedure SaveToStream(Stream: TStream); virtual;
    procedure WriteLn(Stream: TStream; S: String);
    procedure Write(Stream: TStream; S: String);
  published
    property XrefPosition: Cardinal read FXrefPosition;
    property Index: Integer read FIndex write FIndex;
  end;

  TfrxPDFToolkit = class(TObject)
  public
    Locale: String;
    Prefix: String;
    LineHeight: Extended;
    constructor Create;
    function GetLocaleInformation(Flag: Integer): String;
    function UnicodePrefix: String;
    function GetHTextPos(Left: Extended; Width: Extended; const Text: String;
      Align: TfrxHAlign): Extended;
    function GetVTextPos(Top: Extended; Height: Extended; const Text: String;
      Align: TfrxVAlign; Line: Integer = 0; Count: Integer = 1): Extended;
    function GetLineWidth(const Text: String): Extended;
    function TruncReturns(Str: string): string;
    function PrepareString(const Text: String): String;
    function GetPDFColor(Color: TColor): String;
    function CheckOEM(const Value: string): boolean;
    function StrToOct(const Value: String): String;
    function StrToOctUTF16(const Value: String): String;
    function Dec2Oct(i: Longint): String;
    procedure SetMemo(Memo: TfrxCustomMemoView);
    function Str2RTL(const Str: String): String;
  end;

  TfrxPDFFile = class(TfrxPDFElement)
  private
    FPages: TList;
    FFonts: TList;
    FXRef: TStringList;
    FCounter: Integer;
    FTitle: String;
    FStartXRef: Cardinal;
    FStartFonts: Integer;
    FStartPages: Integer;
    FPagesRoot: Integer;
    FCompressed: Boolean;
    FPrintOpt: Boolean;
    FOutline: Boolean;
    FPreviewOutline: TfrxCustomOutline;
    FSubject: String;
    FAuthor: String;
    FBackground: Boolean;
    FCreator: String;
    FHTMLTags: Boolean;
  public
    FEmbedded: Boolean;
    FFontDCnt: Integer;
    PTool: TfrxPDFToolkit;
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure XRefAdd(Stream: TStream);
    procedure SaveToStream(Stream: TStream); override;
    function AddPage(Page: TfrxReportPage): TfrxPDFPage;
    function AddFont(Font: TFont): Integer;
  published
    property Pages: TList read FPages;
    property Fonts: TList read FFonts;
    property Counter: Integer read FCounter write FCounter;
    property Title: String read FTitle write FTitle;
    property Compressed: Boolean read FCompressed write FCompressed;
    property EmbeddedFonts: Boolean read FEmbedded write FEmbedded default True;
    property PrintOptimized: Boolean read FPrintOpt write FPrintOpt;
    property Outline: Boolean read FOutline write FOutline;
    property PreviewOutline: TfrxCustomOutline read FPreviewOutline write FPreviewOutline;
    property Author: String read FAuthor write FAuthor;
    property Subject: String read FSubject write FSubject;
    property Background: Boolean read FBackground write FBackground;
    property Creator: String read FCreator write FCreator;
    property HTMLTags: Boolean read FHTMLTags write FHTMLTags;
  end;

  TfrxPDFPage = class(TfrxPDFElement)
  private
    FParent: TfrxPDFFile;
    FStreamObjects: TMemoryStream;
    FWidth: Extended;
    FHeight: Extended;
    FMarginLeft: Extended;
    FMarginTop: Extended;
    function GetLeft(Left: Extended): Extended;
    function GetTop(Top: Extended): Extended;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure SaveToStream(Stream: TStream); override;
    procedure AddObject(Obj: TfrxView);
  published
    property Parent: TfrxPDFFile read FParent write FParent;
    property Width: Extended read FWidth write FWidth;
    property Height: Extended read FHeight write FHeight;
    property MarginLeft: Extended read FMarginLeft write FMarginLeft;
    property MarginTop: Extended read FMarginTop write FMarginTop;
  end;

  TfrxPDFFont = class(TfrxPDFElement)
  private
    FFont: TFont;
    FParent: TfrxPDFFile;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
  published
    property Parent: TfrxPDFFile read FParent write FParent;
    property Font: TFont read FFont;
  end;

  TfrxPDFOutlineNode = class(TObject)
  public
    Title: String;
    Dest: Integer;
    Top: Integer;
    Number: Integer;
    CountTree: Integer;
    Count: Integer;
    First: TfrxPDFOutlineNode;
    Last: TfrxPDFOutlineNode;
    Parent: TfrxPDFOutlineNode;
    Prev: TfrxPDFOutlineNode;
    Next: TfrxPDFOutlineNode;
    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses frxGraphicUtils, frxGzip;

const
  PDF_VER = '1.3';
  PDF_DIVIDER = 0.75;
  PDF_MARG_DIVIDER = 0.5;
  PDF_PRINTOPT = 4;

type
  PABC = ^ABCarray;
  ABCarray = array [0..255] of ABC;

function ReverseString(const AText: string): string;
var
  I: Integer;
  P: PChar;
begin
  SetLength(Result, Length(AText));
  P := PChar(Result);
  for I := Length(AText) downto 1 do
  begin
    P^ := AText[I];
    Inc(P);
  end;
end;

{ TfrxPDFFile }

constructor TfrxPDFFile.Create;
begin
  PTool := TfrxPDFToolkit.Create;
  FPages := TList.Create;
  FFonts := TList.Create;
  FXRef := TStringList.Create;
  FCounter := 4;
  FStartPages := 0;
  FStartXRef := 0;
  FStartFonts := 0;
  FCompressed := True;
  FPrintOpt := False;
  FOutline := False;
  FPreviewOutline := nil;
  FHTMLTags := False;
end;

destructor TfrxPDFFile.Destroy;
begin
  Clear;
  FXRef.Free;
  FPages.Free;
  FFonts.Free;
  PTool.Free;
  inherited;
end;

procedure TfrxPDFFile.Clear;
var
  i: Integer;
begin
  for i := 0 to FPages.Count - 1 do
  begin
    TfrxPDFPage(FPages[i]).Free;
  end;
  FPages.Clear;
  for i := 0 to FFonts.Count - 1 do
    TfrxPDFFont(FFonts[i]).Free;
  FFonts.Clear;
  FXRef.Clear;
end;

procedure TfrxPDFFile.SaveToStream(Stream: TStream);
var
  i: Integer;
  s, s1: String;
  Page, Top: Integer;
  Text: String;
  Parent: Integer;
  OutlineCount: Integer;
  NodeNumber: Integer;
  OutlineTree: TfrxPDFOutlineNode;

  function DoCalcOutlineCount: Integer;
  var
    i: Integer;
  begin
    Result := FPreviewOutline.Count;
    for i := 0 to FPreviewOutline.Count - 1 do
    begin
      FPreviewOutline.LevelDown(i);
      Result := Result + DoCalcOutlineCount;
      FPreviewOutline.LevelUp;
    end;
  end;

  procedure DoPrepareOutline(Node: TfrxPDFOutlineNode);
  var
    i: Integer;
    cnt: Integer;
    p: TfrxPDFOutlineNode;
    prev: TfrxPDFOutlineNode;
  begin
    cnt := FPreviewOutline.Count;
    Node.Count := cnt;
    Node.CountTree := cnt;
    Inc(NodeNumber);
    prev := nil;
    p := nil;
    for i := 0 to cnt - 1 do
    begin
      p := TfrxPDFOutlineNode.Create;
      FPreviewOutline.GetItem(i, Text, Page, Top);
      p.Title := Text;
      p.Dest := Page;
      p.Top := Top;
      p.Prev := prev;
      if prev <> nil then
        prev.Next := p
      else
        Node.First := p;
      prev := p;
      p.Parent := Node;
      FPreviewOutline.LevelDown(i);
      DoPrepareOutline(p);
      FPreviewOutline.LevelUp;
      Node.CountTree := Node.CountTree + p.CountTree;
    end;
    Node.Last := p;
  end;

  procedure DoWriteOutline(Node: TfrxPDFOutlineNode; Parent: Integer);
  var
    p: TfrxPDFOutlineNode;
  begin
    p := Node;
    if p.Dest = -1 then
    begin
      p.Number := Parent;
    end
    else begin
      p.Number := FCounter;
      XRefAdd(Stream);
      WriteLn(Stream, IntToStr(FCounter) + ' 0 obj');
      Inc(FCounter);
      WriteLn(Stream, '<<');
      WriteLn(Stream, '/Title (' + PTool.PrepareString(p.Title) + ')');
      WriteLn(Stream, '/Parent ' + IntToStr(Parent) + ' 0 R');
      if p.Prev <> nil then
        WriteLn(Stream, '/Prev ' + IntToStr(p.Prev.Number) + ' 0 R');
      if p.First <> nil then
      begin
        WriteLn(Stream, '/First ' + IntToStr(p.Number + 1) + ' 0 R');
        WriteLn(Stream, '/Last ' + IntToStr(p.Number + p.CountTree - p.Last.CountTree ) + ' 0 R');
        WriteLn(Stream, '/Count ' + IntToStr(p.Count));
      end;
      if p.Next <> nil then
        WriteLn(Stream, '/Next ' + IntToStr(p.Number + p.CountTree + 1) + ' 0 R');
      WriteLn(Stream, '/Dest [' + IntToStr(FpagesRoot + FFonts.Count * FFontDCnt + p.Dest * 2 + 1) + ' 0 R /XYZ 0 ' + IntToStr(Round(TfrxPDFPage(FPages[Page]).Height - p.Top * PDF_DIVIDER)) + ' 0]');
      WriteLn(Stream, '>>');
      WriteLn(Stream, 'endobj');
    end;
    if p.First <> nil then
      DoWriteOutline(p.First, p.Number);
    if p.Next <> nil then
      DoWriteOutline(p.Next, Parent);
  end;

begin