frxpdffile.pas

报表控件。FastReport 是非常强大的报表控件

{******************************************}
{                                          }
{             FastReport v3.0              }
{             PDF file library             }
{                                          }
{         Copyright (c) 1998-2006          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{          Add CJK Font support by         }
{          [e-mail]                }
{          http://hardrock.cnblogs.com     }
{******************************************}

unit frxPDFFile;

interface

{$I frx.inc}

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

type
  TfrxPDFPage = class;
  TfrxPDFFont = class;

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

  TfrxPDFToolkit = class(TObject)
  public
    Divider: Extended;
    LineHeight: Extended;
    LastColor: TColor;
    LastColorResult: String;
    constructor Create;
    function GetHTextPos(const Left: Extended; const Width: Extended; const CharSpacing: Extended;
      const Text: String; const Align: TfrxHAlign): Extended;
    function GetVTextPos(const Top: Extended; const Height: Extended; const Text: String;
      const Align: TfrxVAlign; const Line: Integer = 0; const Count: Integer = 1): Extended;
    function GetLineWidth(const Text: String; const CharSpacing: Extended): Extended;
    procedure SetMemo(const Memo: TfrxCustomMemoView);
  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
    CJKFontNumber: Cardinal;
    FStreamObjects: TStream;
    FTempStreamFile: String;
    FEmbedded: Boolean;
    FFontDCnt: Integer;
    PTool: TfrxPDFToolkit;
    constructor Create(const UseFileCache: Boolean; const TempDir: String);
    destructor Destroy; override;
    procedure Clear;
    procedure XRefAdd(const Stream: TStream);
    procedure SaveToStream(const Stream: TStream); override;
    function AddPage(const Page: TfrxReportPage): TfrxPDFPage;
    function AddFont(const 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
    FStreamOffset: Longint;
    FParent: TfrxPDFFile;
    FWidth: Extended;
    FHeight: Extended;
    FMarginLeft: Extended;
    FMarginTop: Extended;
    FStream: TStream;
    FStreamSize: Longint;
  public
    constructor Create;
    procedure SaveToStream(const Stream: TStream); override;
    procedure AddObject(const Obj: TfrxView);
    property StreamOffset: Longint read FStreamOffset write FStreamOffset;
    property StreamSize: Longint read FStreamSize write FStreamSize;
  published
    property OutStream: TStream read FStream write FStream;
    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(const 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.05;
  PDF_PRINTOPT = 4;

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

function CheckOEM(const Value: String): boolean;
var
  i: integer;
begin
  result := false;
  for i := 1 to Length(Value) do
    if (ByteType(Value, i) <> mbSingleByte) or
       (Ord(Value[i]) > 122) or
       (Ord(Value[i]) < 32) then
    begin
      result := true;
      Break;
    end;
end;

function StrToUTF16(const Value: String): String;
var
  PW: Pointer;
  Len: integer;
  i: integer;
  pwc: ^Word;
begin
  result := 'FEFF';
  Len := MultiByteToWideChar(0, CP_ACP, PChar(Value), Length(Value), nil, 0);
  GetMem(PW, Len * 2);
  try
    Len := MultiByteToWideChar(0, CP_ACP, PChar(Value), Length(Value), PW, Len * 2);
    pwc := PW;
    for i := 0 to Len - 1 do
    begin
      result := result  + IntToHex(pwc^, 4);
      Inc(pwc);
    end;
  finally
    FreeMem(PW);
  end;
end;

function PrepareString(const Text: String): String;
begin
  if CheckOEM(Text) then
    Result := '<' + StrToUTF16(Text) + '>'
  else
    Result := '(' + Text + ')';
end;

{ TfrxPDFFile }

constructor TfrxPDFFile.Create(const UseFileCache: Boolean; const TempDir: String);
begin
  inherited Create;
  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;
  if UseFileCache then
  begin
    FTempStreamFile := frxCreateTempFile(TempDir);
    FStreamObjects := TFileStream.Create(FTempStreamFile, fmCreate);
  end else
    FStreamObjects := TMemoryStream.Create;
  CJKFontNumber := 0;
end;

destructor TfrxPDFFile.Destroy;
begin
  Clear;
  FXRef.Free;
  FPages.Free;
  FFonts.Free;
  PTool.Free;
  FStreamObjects.Free;
  try
    DeleteFile(FTempStreamFile);
  except
  end;
  inherited;
end;

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

procedure TfrxPDFFile.SaveToStream(const 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(IntToStr(FCounter) + ' 0 obj');
      Inc(FCounter);
      WriteLn('<<');
      WriteLn('/Title ' + PrepareString(p.Title));
      WriteLn('/Parent ' + IntToStr(Parent) + ' 0 R');
      if p.Prev <> nil then
        WriteLn('/Prev ' + IntToStr(p.Prev.Number) + ' 0 R');
      if p.First <> nil then
      begin
        WriteLn('/First ' + IntToStr(p.Number + 1) + ' 0 R');
        WriteLn('/Last ' + IntToStr(p.Number + p.CountTree - p.Last.CountTree ) + ' 0 R');
        WriteLn('/Count ' + IntToStr(p.Count));
      end;
      if p.Next <> nil then
        WriteLn('/Next ' + IntToStr(p.Number + p.CountTree + 1) + ' 0 R');
      WriteLn('/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('>>');
      WriteLn('endobj');
      Flush(Stream);
    end;
    if p.First <> nil then
      DoWriteOutline(p.First, p.Number);
    if p.Next <> nil then
      DoWriteOutline(p.Next, Parent);
  end;

begin
  inherited SaveToStream(Stream);
  OutlineCount := 0;
  OutlineTree := nil;
  if FOutline then
    if not Assigned(FPreviewOutline) then
      FOutline := False
    else
      FPreviewOutline.LevelRoot;
  FCounter := 1;
  s := FormatDateTime('yyyy', Now) + FormatDateTime('mm', Now) +
    FormatDateTime('dd', Now) + FormatDateTime('hh', Now) +
    FormatDateTime('nn', Now) + FormatDateTime('ss', Now);
  WriteLn('%PDF-' + PDF_VER);
  WriteLn('%'#226#227#207#211);
  Flush(Stream);
  XRefAdd(Stream);
  WriteLn(IntToStr(FCounter) + ' 0 obj');
  Inc(FCounter);
  WriteLn('<<');
  WriteLn('/Type /Catalog');
  i := 0;

  if FOutline then
  begin
    OutlineTree := TfrxPDFOutlineNode.Create;
    NodeNumber := 0;
    DoPrepareOutline(OutlineTree);
    if OutlineTree.CountTree > 0 then
    begin
      OutlineCount := OutlineTree.CountTree - OutlineTree.Last.CountTree;
      i := OutlineTree.CountTree + 1;
    end else
      FOutline := False;
  end;

  FPagesRoot := 3 + i;
  WriteLn('/Pages ' + IntToStr(FPagesRoot) + ' 0 R');
  if FOutline then s1 := '/UseOutlines'
  else s1 := '/UseNone';