frxpdffile.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{             PDF file library             }
{                                          }
{         Copyright (c) 1998-2008          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{******************************************}
{          Add CJK Font support by         }
{          [e-mail]           }
{          http://www.jane.com.tw          }
{******************************************}

unit frxPDFFile;

interface

{$I frx.inc}
{$DEFINE PDF_RC4}

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  ComObj, ComCtrls, frxClass, frxUtils, JPEG, frxUnicodeUtils
{$IFDEF Delphi6}, Variants {$ENDIF}
{$IFDEF PDF_RC4}, frxRC4{$ELSE}, frxRC4, frxAES{$ENDIF}
{$IFDEF Delphi10}
, WideStrings
{$ENDIF}
{$IFDEF Delphi12}
, AnsiStrings
{$ENDIF};

type
  TfrxPDFEncBit = (ePrint, eModify, eCopy, eAnnot);
  TfrxPDFEncBits = set of TfrxPDFEncBit;
  TfrxPDFPage = class;
  TfrxPDFFont = class;

  TfrxPDFElement = class(TObject)
  private
    FXrefPosition: Cardinal;
    FIndex: Integer;
    FCR: Boolean;
    procedure Write(Stream: TStream; const S: AnsiString);{$IFDEF Delphi12} overload;
    procedure Write(Stream: TStream; const S: String); overload;
{$ENDIF}
    procedure WriteLn(Stream: TStream; const S: AnsiString);{$IFDEF Delphi12} overload;
    procedure WriteLn(Stream: TStream; const S: String); overload;
{$ENDIF}
  public
    constructor Create;
    procedure SaveToStream(const Stream: TStream); virtual;
    property XrefPosition: Cardinal read FXrefPosition;
    property Index: Integer read FIndex write FIndex;
  end;

  TfrxPDFFile = class(TfrxPDFElement)
  private
    FPages: TList;
    FFonts: TList;
    FXRef: TStringList;
    FObjNo: Integer;
    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;
    FPageNumbers: String;
    FTotalPages: Integer;
    FFileID: AnsiString;
    FProtection: Boolean;
    FEncBits: Cardinal;
    FProtectionFlags: TfrxPDFEncBits;
    FOwnerPassword: AnsiString;
    FUserPassword: AnsiString;
    FEncKey: AnsiString;
    FOPass: AnsiString;
    FUPass: AnsiString;
    FKeywords: WideString;
    FProducer: WideString;
    FPrintScaling: Boolean;
    FFitWindow: Boolean;
    FHideMenubar: Boolean;
    FCenterWindow: Boolean;
    FHideWindowUI: Boolean;
    FHideToolbar: Boolean;
    procedure PrepareKeys;
    function GetOwnerPassword: AnsiString;
    function GetUserPassword: AnsiString;
    procedure SetProtectionFlags(const Value: TfrxPDFEncBits);
  public
    FStreamObjects: TStream;
    FTempStreamFile: String;
    FEmbedded: Boolean;
    FFontDCnt: Integer;
    constructor Create(const UseFileCache: Boolean; const TempDir: String);
    destructor Destroy; override;
    procedure Clear;
    procedure XRefAdd(Stream: TStream; ObjNo: Integer);
    procedure SaveToStream(const Stream: TStream); override;
    function AddPage(const Page: TfrxReportPage): TfrxPDFPage;
    function AddFont(const Font: TFont): Integer;
    procedure Start;

    property Pages: TList read FPages;
    property Fonts: TList read FFonts;
    property Counter: Integer read FCounter write FCounter;
    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 Background: Boolean read FBackground write FBackground;

    property Title: String read FTitle write FTitle;
    property Creator: String read FCreator write FCreator;
    property Producer: WideString read FProducer write FProducer;
    property Keywords: WideString read FKeywords write FKeywords;
    property Author: String read FAuthor write FAuthor;
    property Subject: String read FSubject write FSubject;

    property HTMLTags: Boolean read FHTMLTags write FHTMLTags;
    property PageNumbers: String read FPageNumbers write FPageNumbers;
    property TotalPages: Integer read FTotalPages write FTotalPages;
    property Protection: Boolean read FProtection write FProtection;
    property UserPassword: AnsiString read FUserPassword write FUserPassword;
    property OwnerPassword: AnsiString read FOwnerPassword write FOwnerPassword;
    property ProtectionFlags: TfrxPDFEncBits read FProtectionFlags write SetProtectionFlags;

    property HideToolbar: Boolean read FHideToolbar write FHideToolbar;
    property HideMenubar: Boolean read FHideMenubar write FHideMenubar;
    property HideWindowUI: Boolean read FHideWindowUI write FHideWindowUI;
    property FitWindow: Boolean read FFitWindow write FFitWindow;
    property CenterWindow: Boolean read FCenterWindow write FCenterWindow;
    property PrintScaling: Boolean read FPrintScaling write FPrintScaling;
  end;

  TfrxPDFPage = class(TfrxPDFElement)
  private
    FStreamOffset: Longint;
    FParent: TfrxPDFFile;
    FWidth: Extended;
    FHeight: Extended;
    FMarginLeft: Extended;
    FMarginTop: Extended;
    FStream: TStream;
    FStreamSize: Longint;
    FDivider: Extended;
    FLastColor: TColor;
    FLastColorResult: String;
    FBMP: TBitmap;
    FDefFontCharSet: Integer;
    function CodepageByCharset(const Charset: Integer): Integer;
  public
    constructor Create;
    destructor Destroy; override;
    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;

    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;
    FFontDCnt: Integer;
    FCodepage: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SaveToStream(const Stream: TStream); override;

    property Parent: TfrxPDFFile read FParent write FParent;
    property Font: TFont read FFont;
    property Codepage: Integer read FCodepage write FCodepage;
  end;

  TfrxPDFOutlineNode = class(TObject)
  private
    FNumber: Integer;
    FDest: Integer;
    FTop: Integer;
    FCountTree: Integer;
    FCount: Integer;
    FTitle: String;
    FLast: TfrxPDFOutlineNode;
    FNext: TfrxPDFOutlineNode;
    FParent: TfrxPDFOutlineNode;
    FPrev: TfrxPDFOutlineNode;
    FFirst: TfrxPDFOutlineNode;
  public
    constructor Create;
    destructor Destroy; override;
    property Title: String read FTitle write FTitle;
    property Dest: Integer read FDest write FDest;
    property Top: Integer read FTop write FTop;
    property Number: Integer read FNumber write FNumber;
    property CountTree: Integer read FCountTree write FCountTree;
    property Count: Integer read FCount write FCount;
    property First: TfrxPDFOutlineNode read FFirst write FFirst;
    property Last: TfrxPDFOutlineNode read FLast write FLast;
    property Parent: TfrxPDFOutlineNode read FParent write FParent;
    property Prev: TfrxPDFOutlineNode read FPrev write FPrev;
    property Next: TfrxPDFOutlineNode read FNext write FNext;
  end;

implementation

uses frxGraphicUtils, frxGzip, frxMD5, ActiveX, SyncObjs, math;

var
  pdfCS: TCriticalSection;

const
  PDF_VER = '1.5';
  PDF_DIVIDER = 0.75;
  PDF_MARG_DIVIDER = 0.05;
  PDF_PRINTOPT = 3;
  PDF_PK: array [ 1..32 ] of Byte =
    ( $28, $BF, $4E, $5E, $4E, $75, $8A, $41, $64, $00, $4E, $56, $FF, $FA, $01, $08,
      $2E, $2E, $00, $B6, $D0, $68, $3E, $80, $2F, $0C, $A9, $FE, $64, $53, $69, $7A );

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

function GetID: AnsiString;
var
  AGUID: TGUID;
  AGUIDString: widestring;
begin
  CoCreateGUID(AGUID);
  SetLength(AGUIDString, 39);
  StringFromGUID2(AGUID, PWideChar(AGUIDString), 39);
  Result := AnsiString(PWideChar(AGUIDString));
  MD5String(AnsiString(PWideChar(AGUIDString)));
end;

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

function GetLocaleInformation(Flag: Integer): AnsiString;
var
  pcLCA: array[0..20] of AnsiChar;
begin
  if (GetLocaleInfoA(LOCALE_SYSTEM_DEFAULT, Flag, pcLCA,19) <= 0 ) then
    pcLCA[0] := #0;
  Result := pcLCA;
end;

function CheckOEM(const Value: WideString): 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 StrToUTF16U(const Value: WideString): AnsiString;
var
  i: integer;
  pwc: ^Word;
begin
  result := 'FEFF';
  for i := 1 to Length(Value) do
  begin
    pwc := @Value[i];
    result := result  + AnsiString(IntToHex(pwc^, 4));
  end;
end;

function StrToHex(const Value: AnsiString): AnsiString;
var
  i: integer;
begin
  result := '';
  for i := 1 to Length(Value) do
    result := result  + AnsiString(IntToHex(Byte(Value[i]), 2));
end;

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

function HexEncode7F(Str: WideString): AnsiString;
var
  s: AnsiString;
  Index, Len: Integer;
begin
  s := '';
  Len := Length(Str);
  Index := 0;
  while Index < Len do
  begin
    Index := Index + 1;
    if Byte(Str[Index]) > $7F then
      s := s + '#' + AnsiString(IntToHex(Byte(Str[Index]), 2))
    else
      s := s + AnsiString(Str[Index]);
  end;
  Result := s;
end;

function Dec2Oct(const i: Longint): AnsiString;
var
  m, j: Longint;
Begin
  Result := '';
  j := i;
  while j > 0 Do
  begin
    m := j mod 8;
    Result := AnsiChar(m + Ord('0')) + Result;
    j := j div 8;
  end;
  Result := StringOfChar(AnsiChar('0'),  3 - Length(Result)) + Result;
end;

function StrToOct(const Value: AnsiString): AnsiString;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Value) do
    Result := Result + '\' + Dec2Oct(Ord(Value[i]));
end;

function EscapeSpecialChar(TextStr: AnsiString): AnsiString;