rtfreadwrite2.pas

一个经典的读写Excel的控件

    end;
    kwdChar: begin
      FOutputText := True;
      Result := ecParseChar(WideChar(rgsymRtf[isym].idx));
    end;
    kwdUnicode:
      Result := ecParseChar(WideChar(lParam));
    kwdUnicodeGroup: begin
      FInUnicodeGroup := lParam = 2;
      Result := ecOk;
    end;
    kwdDest: begin
      Result := ecChangeDest(TIDEST(rgsymRtf[isym].idx));
    end;
    kwdSpec:
      Result := ecParseSpecialKeyword(TIPFN(rgsymRtf[isym].idx));
  end;
end;

//
// %%Function: ecChangeDest
//
// Change to the destination specified by idest.
// There's usually more to do here than this...
//

function TRTFReader.ecChangeDest(idest: TIDEST): integer;
begin
  if FRDS = rdsSkip then
    Result := ecOK                // don't do anything
  else begin
    case idest of
      idestPict: begin
        FRDS := rdsSkip;
      end;
      idestFontTbl: begin
        FRDS := rdsFontTbl;
      end;
      idestFont: begin
        if FRDS = rdsFontTbl then begin
          FRDS := rdsFont;
          FStringParam := '';
          FFonts.Add(lParam);
        end
        else begin
          FCHP.FontName := FFonts[lParam].Name;
          FontChanged;
          // Not sure if this is the correct way to detect document text,
          // but all text seems to be receded with a font.
          FOutputText := True;
        end;
      end;
      idestColorTbl:
        FRIS := risColorTbl;
      idestFontColor: begin
        if lParam <= High(FColorTable) then begin
          FCHP.FontColor := FColorTable[lParam];
          FontChanged;
        end
        else begin
          Result := ecAssertion;
          Exit;
        end;
      end;
      idestCharSet: begin
        if FRDS = rdsFont then begin
          FFonts.Last.CharSet := lParam;
        end;
      end;
      else
        FRDS := rdsSkip;              // when in doubt, skip it...
    end;
    Result := ecOK;
  end;
end;

//
// %%Function: ecEndGroupAction
//
// The destination specified by rds is coming to a close.
// If there's any cleanup that needs to be done, do it now.
//

function TRTFReader.ecEndGroupAction(rds: TRDS): integer;
begin
  if RDS = rdsFont then begin
{$ifdef OLD_COMPILER}
    if Copy(FStringParam,1,1) = ';' then
{$else}
    if RightStr(FStringParam,1) = ';' then
{$endif}
      FStringParam := Copy(FStringParam,1,Length(FStringParam) -1);
    FFonts.Last.Name := FStringParam;
  end;
  Result := ecOK;
end;

//
// %%Function: ecParseSpecialKeyword
//
// Evaluate an RTF control that needs special processing.
//

function TRTFReader.ecParseSpecialKeyword(ipfn: TIPFN): integer;
begin
  if (FRDS = rdsSkip) and (ipfn <> ipfnBin) then  // if we're skipping, and it's not
    Result := ecOK                        // the \bin keyword, ignore it.
  else begin
    case ipfn of
      ipfnBin: begin
        FRIS := risBin;
        cbBin := lParam;
      end;
      ipfnSkipDest:
        fSkipDestIfUnk := True;
      ipfnHex:
        FRIS := risHex;
      else begin
        Result := ecBadTable;
        Exit;
      end;
    end;
    Result := ecOK;
  end;
end;

{ TRtfFont }

constructor TRtfFont.Create(Id: integer);
begin
  FId := Id;
end;

{ TRtfFonts }

procedure TRtfFonts.Add(Id: integer);
begin
  inherited Add(TRtfFont.Create(Id));
end;

function TRtfFonts.GetItemByIndex(Index: integer): TRtfFont;
begin
  Result := TRtfFont(inherited Items[Index]);
end;

function TRtfFonts.GetItems(Id: integer): TRtfFont;
var
  i,First,Last: Integer;
begin
  First := 0;
  Last := Count - 1;

  while First <= Last do begin
    i := (First + Last) div 2;
    if ItemByIndex[i].FId = id then begin
      Result := ItemByIndex[i];
      Exit;
    end;
    if ItemByIndex[i].FId > Id then
      Last := i - 1
    else
      First := i + 1;
  end;
  raise Exception.Create('Can not find RTF font');
end;

function TRtfFonts.Last: TRtfFont;
begin
  Result := TRtfFont(inherited Items[Count - 1]);
end;

procedure TRTFReader.FontChanged;
var
  F: TIndexFont;
  Changed: boolean;
begin
  if FCurrTextPos > FLastTextPos then begin
    if (FFontRuns.Count <= 0) or not FFontRuns[FFontRuns.Count - 1].Equal(FCurrFont) then begin
      F := TIndexFont.Create;
      F.Assign(FCurrFont);
      F.Index := FLastTextPos;
      FFontRuns.Add(F);
    end;
    FLastTextPos := FCurrTextPos;
  end;
  Changed := (FCHP.fBold = 1) <> (fsBold in FCurrFont.Style);
  if not Changed then
    Changed := (FCHP.fUnderline = 1) <> (fsUnderline in FCurrFont.Style);
  if not Changed then
    Changed := (FCHP.fItalic = 1) <> (fsItalic in FCurrFont.Style);
  if not Changed then
    Changed := FCHP.FontSize <> (FCurrFont.Size div 2);
  if not Changed then
    Changed := FCHP.FontColor <> FCurrFont.Color;
  if not Changed then
    Changed := AnsiLowercase(FCHP.FontName) <> AnsiLowercase(FCurrFont.Name);
  if Changed then begin
    FCurrFont.Style := [];
    if FCHP.fBold = 1 then
      FCurrFont.Style := FCurrFont.Style + [fsBold];
    if FCHP.fUnderline = 1 then
      FCurrFont.Style := FCurrFont.Style + [fsUnderline];
    if FCHP.fItalic = 1 then
      FCurrFont.Style := FCurrFont.Style + [fsItalic];
    FCurrFont.Size := FCHP.FontSize div 2;
    FCurrFont.Color := FCHP.FontColor;
    FCurrFont.Name := FCHP.FontName;
  end;
end;

{ TIndexFontList }

function TIndexFontList.AddFont: TIndexFont;
begin
  Result := TIndexFont.Create;
  Add(Result);
end;

function TIndexFontList.GetItems(Index: integer): TIndexFont;
begin
  Result := TIndexFont(inherited Items[Index]);
end;

{ TIndexFont }

function TIndexFont.AsRTF: string;
begin
  Result := Format('\fs%d',[Size * 2]);
  if fsBold in Style then
    Result := Result + '\b1'
  else
    Result := Result + '\b0';
  if fsItalic in Style then
    Result := Result + '\i1'
  else
    Result := Result + '\i0' ;
  if fsUnderline in Style then
    Result := Result + '\ul1'
  else
    Result := Result + '\ul0';

end;

function TIndexFont.Equal(F: TIndexFont): boolean;
begin
  Result := (Style = F.Style) and (Size = F.Size) and (Color = F.Color) and (Name = F.Name);
end;

function TRTFReader.ecReadColorTbl(fp: TStream): integer;
var
  S,sColor: string;
  Red,Green,Blue: byte;
  ch: char;

procedure SetColor(S: string);
begin
  if Copy(S,1,3) = 'red' then
    Red := StrToIntDef(Copy(S,4,3),0)
  else if Copy(S,1,5) = 'green' then
    Green := StrToIntDef(Copy(S,6,3),0)
  else if Copy(S,1,4) = 'blue' then
    Blue := StrToIntDef(Copy(S,5,3),0)
end;

begin
  Result := ecOk;
  S := '';
  while fp.Read(ch,1) = 1 do begin
    if ch = '}' then begin
      fp.Seek(-1,soFromCurrent);
      while S <> '' do begin
        Red := 0;
        Green := 0;
        Blue := 0;
        sColor := Copy(GetFirstWord(';',S),2,MAXINT);
        if sColor <> '' then
          SetColor(GetFirstWord('\',sColor));
        if sColor <> '' then
          SetColor(GetFirstWord('\',sColor));
        if sColor <> '' then
          SetColor(sColor);
        SetLength(FColorTable,Length(FColorTable) + 1);
        FColorTable[High(FColorTable)] := (Blue shl 16) + (Green shl 8) + Red;
      end;
      Exit;
    end;
    S := S + ch;
  end;
  Result := ecEndOfFile;
end;

{ TRTFWriter }

procedure TRTFWriter.BeginHeader;
begin
  FRTF := FRTF + '{\rtf1\ansi \ansicpg1252';
end;

procedure TRTFWriter.BeginInfo;
begin
  FRTF := FRTF + '{\info}\plain ';
end;

constructor TRTFWriter.Create;
begin
  FFontRuns := TIndexFontList.Create;
end;

destructor TRTFWriter.Destroy;
begin
  FFontRuns.Free;
  inherited;
end;

function TRTFWriter.EncodeText(S: WideString): string;
var
  W: word;
  i: integer;
begin
  Result := '';
  for i := 1 to Length(S) do begin
    W := Word(S[i]);
    if W <= $7F then begin
      case W of
        $09:
          Result := Result + '\tab ';
        $0A:
          Result := Result + '\par ';
        else
          Result := Result + WideChar(W);
      end;
    end
    else if W <= $FF then
      Result := Result + Format('\''%.2x',[W])
    // The characther after the unicode one, is for old rtf reader. Don't
    // know a meaningsfull value for it.
    else if W <= $7FFF then
      Result := Result + Format('\u%d_',[W])
    else
      Result := Result + Format('\u-%d_',[$FFFF - W + 1]);
  end;
end;

procedure TRTFWriter.EndHeader;
begin

end;

procedure TRTFWriter.EndInfo;
begin
  FRTF := FRTF + '}';
end;

procedure TRTFWriter.SaveToFile(Filename: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(Filename,fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TRTFWriter.SaveToStream(Stream: TStream);
begin
  if FFontRuns.Count <= 0 then
    raise Exception.Create('No fonts in RTF');
  FRTF := '';
  BeginHeader;
  WriteFontTable;
  WriteColorTable;
  EndHeader;
  BeginInfo;
  WriteDocText;
  EndInfo;
  Stream.Write(Pointer(FRTF)^,Length(FRTF));
end;

procedure TRTFWriter.WriteColorTable;
var
  i: integer;
  V: longword;
begin
  // The first color is the default (black).
  FRTF := FRTF + '{\colortbl\red0\green0\blue0;';
  for i := 0 to FFontRuns.Count - 1 do begin
    V := FFontRuns[i].Color;
    FRTF := FRTF + Format('\red%d\green%d\blue%d;',[V and $0000FF,(V shr 8) and $0000FF,(V shr 16) and $0000FF]);
  end;
  FRTF := FRTF + '}';
end;

procedure TRTFWriter.WriteDocText;
var
  i,p: integer;
begin
  FRTF := FRTF + '\f0' + FFontRuns[0].AsRTF;
  if FFontRuns[0].Color <> clBlack then
    FRTF := FRTF + '\cf1';
  p := 0;
  for i := 1 to FFontRuns.Count - 1 do begin
    if FFontRuns[i].Index > p then begin
      FRTF := FRTF + ' ' + EncodeText(Copy(FText,p + 1,FFontRuns[i].Index - p));
      FRTF := FRTF + Format('\f%d',[i]) + FFontRuns[i].AsRTF;
      if FFontRuns[i].Color <> clBlack then
        FRTF := FRTF + Format('\cf%d',[i + 1])
      else
        FRTF := FRTF + '\cf';
      p := FFontRuns[i].Index;
    end;
  end;
  if (p + 1) < Length(FText) then
    FRTF := FRTF + ' ' + EncodeText(Copy(FText,p + 1,MAXINT));
end;

procedure TRTFWriter.WriteFontTable;
var
  i: integer;
begin
  FRTF := FRTF + '{\fonttbl';
  for i := 0 to FFontRuns.Count - 1 do begin
    FRTF := FRTF + Format('{\f%d\fnil %s;}',[i,FFontRuns[i].Name]);
  end;
  FRTF := FRTF + '}';
end;

end.