rtfreadwrite2.pas

一个经典的读写Excel的控件

unit RTFReadWrite2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* Based on a sample RTF reader in Microsoft's Rich Text Format     *******
******* Specification.                                                   *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$I XLSRWII2.inc}

{$B-}

interface

uses Classes, SysUtils, Contnrs, Dialogs, Graphics,
{$ifndef OLD_COMPILER}
     StrUtils,
{$endif}
     XLSFonts2;

type TIndexFont = class(TFont)
private
     FIndex: integer;
public
     function Equal(F: TIndexFont): boolean;
     function AsRTF: string;

     property Index: integer read FIndex write FIndex;
     end;

type TIndexFontList = class(TObjectList)
private
     function GetItems(Index: integer): TIndexFont;
public
     function AddFont: TIndexFont;

     property Items[Index: integer]: TIndexFont read GetItems; default;
     end;

type TCHP = record
    fBold: byte;
    fUnderline: byte;
    fItalic: byte;
    FontSize: integer;
    FontColor: TColor; 
    FontName: WideString;
    end;                  // Character Properties

type TJust =  (justL, justR, justC, justF);

type TPAP = record
    xaLeft: integer;                 // left indent in twips
    xaRight: integer;                // right indent in twips
    xaFirst: integer;                // first line indent in twips
    JUST: TJust;                     // justification
    end;                             // PAragraph Properties

type TSBK = (sbkNon, sbkCol, sbkEvn, sbkOdd, sbkPg);
type TPGN = (pgDec, pgURom, pgLRom, pgULtr, pgLLtr);

type TSEP = record
    cCols: integer;                  // number of columns
    SBK: TSBK;                       // section break type
    xaPgn: integer;                  // x position of page number in twips
    yaPgn: integer;                  // y position of page number in twips
    pgnFormat: TPGN;                       // how the page number is formatted
    end;                             // SEction Properties

type TDOP = record
    xaPage: integer;                 // page width in twips
    yaPage: integer;                 // page height in twips
    xaLeft: integer;                 // left margin in twips
    yaTop: integer;                  // top margin in twips
    xaRight: integer;                // right margin in twips
    yaBottom: integer;               // bottom margin in twips
    pgnStart: integer;               // starting page number in twips
    fFacingp: byte;                  // facing pages enabled?
    fLandscape: byte;                // landscape or portrait??
    end;                             // DOcument Properties

type TRDS = (rdsNorm, rdsSkip, rdsFontTbl, rdsFont);              // Rtf Destination State
type TRIS = (risNorm, risBin, risHex, risColorTbl);        // Rtf Internal State

type PSAVE = ^TSAVE;
    TSAVE = record
    pNext: PSAVE;         // next save
    CHP: TCHP;
    PAP: TPAP;
    SEP: TSEP;
    DOP: TDOP;
    RDS: TRDS;
    RIS: TRIS;
    end;

// What types of properties are there? (Index into FrgProp).
type TIPROP = (ipropBold, ipropItalic, ipropUnderline, ipropFontSize,
              ipropLeftInd,
              ipropRightInd, ipropFirstInd, ipropCols, ipropPgnX,
              ipropPgnY, ipropXaPage, ipropYaPage, ipropXaLeft,
              ipropXaRight, ipropYaTop, ipropYaBottom, ipropPgnStart,
              ipropSbk, ipropPgnFormat, ipropFacingp, ipropLandscape,
              ipropJust, ipropPard, ipropPlain, ipropSectd,
              ipropMax);

type TACTN = (actnSpec, actnByte, actnWord);
type TPROPTYPE = (propChp, propPap, propSep, propDop);

type TPROP = record
    ACTN: TACTN;              // size of value
    prop: TPROPTYPE;
    PData: PByteArray;
    end;

type TIPFN = (ipfnBin, ipfnHex, ipfnSkipDest);
type TIDEST = (idestPict, idestSkip, idestFont, idestFontTbl, idestColorTbl,idestFontColor, idestCharSet);
type TKWD = (kwdChar, kwdUnicode, kwdUnicodeGroup, kwdDest, kwdProp, kwdSpec);

type TRtfFont = class(TObject)
private
     FId: integer;
     FCharSet: integer;
     FName: WideString;
public
     constructor Create(Id: integer);

     property Id: integer read FId write FId;
     property CharSet: integer read FCharSet write FCharSet;
     property Name: WideString read FName write FName;
     end;

type TRtfFonts = class(TObjectList)
private
     function GetItems(Id: integer): TRtfFont;
     function GetItemByIndex(Index: integer): TRtfFont;
public
     procedure Add(Id: integer);
     function Last: TRtfFont;

     property Items[Id: integer]: TRtfFont read GetItems; default;
     property ItemByIndex[Index: integer]: TRtfFont read GetItemByIndex;
     end;

type TRTFStackItem = class(TObject)
private
     FRDS: TRDS;
     FRIS: TRIS;
     FCHP: TCHP;
     FPAP: TPAP;
     FSEP: TSEP;
     FDOP: TDOP;
public
     constructor Create(RDS: TRDS; RIS: TRIS; CHP: TCHP; PAP: TPAP; SEP: TSEP; DOP: TDOP);

     property RDS: TRDS read FRDS write FRDS;
     property RIS: TRIS read FRIS write FRIS;
     property CHP: TCHP read FCHP write FCHP;
     property PAP: TPAP read FPAP write FPAP;
     property SEP: TSEP read FSEP write FSEP;
     property DOP: TDOP read FDOP write FDOP;
     end;

type TRTFStack = class(TObjectList)
private
     function GetItems(Index: integer): TRTFStackItem;
public
     procedure Push(RDS: TRDS; RIS: TRIS; CHP: TCHP; PAP: TPAP; SEP: TSEP; DOP: TDOP);
     procedure Pop(var RDS: TRDS; var RIS: TRIS; var CHP: TCHP; var PAP: TPAP; var SEP: TSEP; var DOP: TDOP);

     property Items[Index: integer]: TRTFStackItem read GetItems; default;
     end;

type TRTFReader = class(TObject)
private
     FrgProp: array of TPROP;
     FStack: TRTFStack;
     cGroup: integer;
     fSkipDestIfUnk: boolean;
     cbBin: integer;
     lParam: integer;
     FRDS: TRDS;
     FRIS: TRIS;
     FCHP: TCHP;
     FPAP: TPAP;
     FSEP: TSEP;
     FDOP: TDOP;
     FInUnicodeGroup: boolean;
     FOutputText: boolean;
     FIncludeAllText: boolean;
     FText: WideString;
     FCurrTextPos,FLastTextPos: integer;
     // Shall not be WideString. Only 7-bit ascii is permited in RTF files.
     FStringParam: string;
     FFonts: TRtfFonts;
     FCurrFont: TIndexFont;
     FFontRuns: TIndexFontList;
     FColorTable: array of TColor;

     function  ecRtfParse(fp: TStream): integer;
     procedure ecPushRtfState;
     function  ecPopRtfState: integer;
     function  ecParseRtfKeyword(fp: TStream): integer;
     function  ecParseChar(ch: WideChar): integer;
     function  ecTranslateKeyword(szKeyword: string; param: integer; fParam: boolean): integer;
     procedure ecPrintChar(ch: WideChar);
     function  ecEndGroupAction(RDS: TRDS): integer;
     function  ecApplyPropChange(IPROP: TIPROP; val: integer): integer;
     function  ecChangeDest(IDEST: TIDEST): integer;
     function  ecParseSpecialKeyword(IPFN: TIPFN): integer;
     function  ecParseSpecialProperty(IPROP: TIPROP; val: integer): integer;
     function  ecReadColorTbl(fp: TStream): integer;
     procedure FontChanged;
//     function ecParseHexByte: integer;
public
     constructor Create;
     destructor Destroy; override;
     procedure LoadFromFile(Filename: string);
     procedure LoadFromStream(Stream: TStream);

     property Text: WideString read FText;
     property FontRuns: TIndexFontList read FFontRuns;
     property IncludeAllText: boolean read FIncludeAllText write FIncludeAllText;
     end;

type TRTFWriter = class(TObject)
private
     FRTF: string;
     FText: WideString;
     FFontRuns: TIndexFontList;

     procedure BeginHeader;
     procedure WriteFontTable;
     procedure WriteColorTable;
     procedure EndHeader;
     procedure BeginInfo;
     procedure WriteDocText;
     procedure EndInfo;
     function  EncodeText(S: WideString): string;
public
     constructor Create;
     destructor Destroy; override;
     procedure SaveToFile(Filename: string);
     procedure SaveToStream(Stream: TStream);

     property Text: WideString read FText write FText;
     property FontRuns: TIndexFontList read FFontRuns;
     end;

// RTF parser error codes

const ecOK                = 0;       // Everything's fine!
const ecStackUnderflow    = 1;       // Unmatched '}'
const ecStackOverflow     = 2;       // Too many '{' -- memory exhausted
const ecUnmatchedBrace    = 3;       // RTF ended during an open group.
const ecInvalidHex        = 4;       // invalid hex character found in data
const ecBadTable          = 5;       // RTF table (sym or prop) invalid
const ecAssertion         = 6;       // Assertion failure
const ecEndOfFile         = 7;       // End of file reached while reading RTF

implementation

function CPos(C: char; S: string): integer;
begin
  for Result := 1 to Length(S) do begin
    if S[Result] = C then
      Exit;
  end;
  Result := -1;
end;

function GetFirstWord(C: char; var S: string): string;
var
  p: integer;
begin
  p := CPos(C,S);
  if p < 1 then begin
    Result := S;
    S := '';
  end
  else begin
    Result := Copy(S,1,p - 1);
    S := Copy(S,p + 1,MAXINT);
  end;
end;

{ TRTFReader }

constructor TRTFReader.Create;

procedure AddProp(ACTN: TACTN; prop: TPROPTYPE; PData: PByteArray);
begin
  SetLength(FrgProp,Length(FrgProp) + 1);
  FrgProp[High(FrgProp)].ACTN := ACTN;
  FrgProp[High(FrgProp)].prop := prop;
  FrgProp[High(FrgProp)].PData := PData;
end;


begin
  FIncludeAllText := True;
  FStack := TRTFStack.Create;
  FFonts := TRtfFonts.Create;
  FCurrFont := TIndexFont.Create;
  FFontRuns := TIndexFontList.Create;
  AddProp(actnByte,propChp,@FCHP.fBold);
  AddProp(actnByte,propChp,@FCHP.fItalic);
  AddProp(actnByte,propChp,@FCHP.fUnderline);
  AddProp(actnWord,propChp,@FCHP.FontSize);
  AddProp(actnWord,propPap,@FPAP.xaLeft);
  AddProp(actnWord,propPap,@FPAP.xaRight);
  AddProp(actnWord,propPap,@FPAP.xaFirst);
  AddProp(actnWord,propSep,@FSEP.cCols);
  AddProp(actnWord,propSep,@FSEP.xaPgn);
  AddProp(actnWord,propSep,@FSEP.yaPgn);
  AddProp(actnWord,propDop,@FDOP.xaPage);
  AddProp(actnWord,propDop,@FDOP.yaPage);
  AddProp(actnWord,propDop,@FDOP.xaLeft);
  AddProp(actnWord,propDop,@FDOP.xaRight);
  AddProp(actnWord,propDop,@FDOP.yaTop);
  AddProp(actnWord,propDop,@FDOP.yaBottom);
  AddProp(actnWord,propDop,@FDOP.pgnStart);
  AddProp(actnByte,propSep,@FSEP.sbk);
  AddProp(actnByte,propSep,@FSEP.pgnFormat);
  AddProp(actnByte,propDop,@FDOP.fFacingp);
  AddProp(actnByte,propDop,@FDOP.fLandscape);
  AddProp(actnByte,propPap,@FPAP.just);
  AddProp(actnSpec,propPap,Nil);
  AddProp(actnSpec,propChp,Nil);
  AddProp(actnSpec,propSep,Nil);
end;

destructor TRTFReader.Destroy;
begin
  FStack.Free;
  FFonts.Free;
  FCurrFont.Free;
  FFontRuns.Free;
  inherited Destroy;
end;

procedure TRTFReader.LoadFromFile(Filename: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(Filename,fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TRTFReader.LoadFromStream(Stream: TStream);
var
  Res: integer;
begin
  FText := '';
  FCurrTextPos := 0;
  FLastTextPos := 0;
  FOutputText := False;
  FFonts.Clear;
  SetLength(FColorTable,0);
  Res := ecRtfParse(Stream);
  if Res <> ecOk then
    raise Exception.CreateFmt('Error while reading RTF document (%d)',[Res]);
  FontChanged;
end;

//
// %%Function: ecRtfParse
//
// Step 1:
// Isolate RTF keywords and send them to ecParseRtfKeyword;
// Push and pop state at the start and end of RTF groups;
// Send text to ecParseChar for further processing.
//

function TRTFReader.ecRtfParse(fp: TStream): integer;
var
  ch: char;
  cNibble: integer;
  b: integer;
begin
  cNibble := 2;
  b := 0;
  while fp.Read(ch,1) = 1 do begin
    if cGroup < 0 then begin
      Result := ecStackUnderflow;
      Exit;
    end;
    if FRIS = risBin then begin                      // if we're parsing binary data, handle it directly
      Result := ecParseChar(WideChar(ch));
      if Result <> Integer(ecOK) then
          Exit;
    end
    else begin
      case ch of
        '{': begin
           FOutputText := False;
           FInUnicodeGroup := False;
           ecPushRtfState;
        end;
        '}': begin
           FOutputText := False;
           FInUnicodeGroup := False;
           Result := ecPopRtfState;
           if Result <> ecOK then
             Exit;
          end;
        '\': begin
           Result := ecParseRtfKeyword(fp);
           if (Result = ecOk) and (FRIS = risColorTbl) then
             Result := ecReadColorTbl(fp);
           if Result <> ecOK then
             Exit
          end;
        Char($0D),Char($0A): ;          // cr and lf are noise characters...
        else begin