rtfexport.~pas

这是一个有关文本编辑器的源程序,支持彩色语法,你可以任意修改,修改后发给我一份

   Inc(FTokenEnd);
   While Not (FTokenEnd^ in ['a'..'z', 'A'..'Z', '0'..'9', #127..#255, #13, #10, ' ']) do
   begin
    if FTokenEnd^ = Chr(0) then begin Inc(FTokenLine); FEof := True; break; end;
    Inc(FTokenEnd);
   end;
   FTokenType := tkCommon;
  end;
 end;
 FTokenPos := FTokenBegin - FBufBeg + 1;
 FTokenString := Copy(FTxt, FTokenPos, FTokenEnd - FTokenBegin);
 //Rem Comment---compatible with Oracle Sql
(* if UpperCase(FTokenString) = 'REM' then
 begin
  P := FTokenBegin;
  While ((P > FBufBeg) and (P^ <> Chr(10))) do
   Dec(P);
  if P^ = Chr(10) then Inc(P);
  Tmp := Copy(Ftxt, P - FBufBeg + 1, FTokenBegin - P);
  if Trim(Tmp) = '' then //Leading char is null-->Sentence begin with REM
  begin
   FTokenType := tkComment;
   While True do
    Case FTokenEnd^ of
     Chr(13): begin Inc(FTokenLine); Break; end;
     Chr(0) : begin Inc(FTokenLine); FEof := True; Break; end;
     else
      Inc(FTokenEnd);
    end;
   FTokenString := Copy(FTxt, FTokenPos, FTokenEnd - FTokenBegin);
   Tmp := FTokenString;
  end;
 end; *)
end;

{ TRtfWriter }

procedure TRtfWriter.BeginWrite;
begin
 FMem.Write(Head[1], Length(Head));
end;

constructor TRtfWriter.Create;
begin
 FMem := TMemoryStream.Create;
 FList := TStringList.Create;
end;

destructor TRtfWriter.Destroy;
begin
 FMem.Free;
 FList.Free;
 inherited;
end;

procedure TRtfWriter.EndWrite;
begin
 FMem.Write(Tail[1], Length(Tail));
end;

function TRtfWriter.RtfTxt: string;
var
 Pos: Int64;
begin
 Pos := FMem.Position;
 SetLength(Result, FMem.Size);
 FMem.Read(Result[1], FMem.Size);
 FMem.Position := Pos;
end;

procedure TRtfWriter.SaveToFile(FileName: string);
begin
 FMem.SaveToFile(FileName);
end;

procedure TRtfWriter.WriteReturn;
begin
 FMem.Write(RCrLn[1], Length(RCrLn));
end;

//process special Character in Txt
function TRtfWriter.ProcessText(Txt: string): String;
Const
 ChTbl = ['\', '{', '}', Chr(VK_Tab)];
var
 I: Integer;
begin
 Result := '';
 For I := 1 to Length(Txt) do
 begin
  if Txt[I] in ChTbl then
   Result := Result + '\' + Txt[I]
  else
   Result := Result + Txt[I];
 end;
end;

procedure TRtfWriter.Write(Txt: string);
begin
end;

procedure TRtfWriter.WriteText(Txt: string; Color: TStd16Color; Bold: Boolean);
Const
 ColorBold = '\cf%d\b\f0\fs20 %s\cf0\b0';
 ColorNormal = '\cf%d %s\cf0';
var
 I, ColorIndex: Integer;
 Tmp: string;
begin
 if Txt = Chr(13) then
 begin
  WriteReturn;
  exit;
 end;
 ColorIndex := Ord(Color) + 1;
 //Process Multi-Lines
 if Pos(Chr(13) + Chr(10), Txt) <> 0 then
 begin
  FList.Text := ProcessText(Txt);
  For I := 0 to FList.Count-1 do
  begin
   Tmp := FList.Strings[I];
   Case Bold of
    True : Txt := Format(ColorBold, [ColorIndex, Tmp]);
    False: Txt := Format(ColorNormal, [ColorIndex, Tmp]);
   end;
   FMem.Write(Txt[1], Length(Txt));
   WriteReturn;
  end;
 end
 else
 begin
  Txt := ProcessText(Txt);
  Case Bold of
   True : Txt := Format(ColorBold, [ColorIndex, Txt]);
   False: Txt := Format(ColorNormal, [ColorIndex, Txt]);
  end;
  FMem.Write(Txt[1], Length(Txt));
 end;
end;

{ TTxt2Rtf }

constructor TTxt2Rtf.Create;
begin
 FKeyWords := TStringList.Create;
 //FKeyWords.LoadFromFile(ExtractFilePath(Application.ExeName) + 'Key.txt');
 FCaseSensitive := False;
 FNeedColor := True;
end;

destructor TTxt2Rtf.Destroy;
begin
 FKeyWords.Free;
 inherited;
end;

function TTxt2Rtf.HasKey(Keyword: String): Boolean;
begin
 Result := FKeyWords.IndexOf(KeyWord) <> -1;
end;

procedure TTxt2Rtf.SaveTextToRtfFile(Txt, SaveFileName: string);
var
 W : TRtfWriter;
 Par: TmParser;
 Color: TStd16Color;
 Bold: Boolean;
begin
 try
  Par := TmParser.Create(Txt, False);
  W := TRtfWriter.Create;
  W.BeginWrite;
  //tkComment, tkIdentifier, tkInteger, tkFloat, tkConst, tkOperator, tkCommon, tkError
  Bold := False;
  Case Par.TokenType of
   tkComment                     : Color := sclMaroon;
   tkConst, tkInteger, tkFloat   : Color := sclRed;
   tkError                       : Color := sclNavy;
   tkOperator                    : Color := sclGreen;
   tkIdentifier, tkCommon        : begin
                                    if HasKey(Par.TokenString) then
                                    begin
                                     Color := sclBlue;
                                     Bold := True;
                                    end
                                    else
                                    begin
                                     Color := sclBlack;
                                     Bold := False;
                                    end;
                                   end;
  end;
  if Not NeedColor then Color := sclBlack;
  W.WriteText(Par.TokenString, Color, Bold);
  Par.NextToken;
  While Not Par.Eof do
  begin
   Bold := False;
   Case Par.TokenType of
    tkComment                     : Color := sclMaroon;
    tkConst, tkInteger, tkFloat   : Color := sclRed;
    tkError                       : Color := sclNavy;
    tkOperator                    : Color := sclGreen;
    tkIdentifier, tkCommon        : begin
                                     if HasKey(Par.TokenString) then
                                     begin
                                      Color := sclBlue;
                                      Bold := True;
                                     end
                                     else
                                     begin
                                      Color := sclBlack;
                                      Bold := False;
                                     end;
                                    end;
    //tkCrLn : Color := clBlack;
   end;
   if Not NeedColor then Color := sclBlack;
   W.WriteText(Par.TokenString, Color, Bold);
   Par.NextToken;
  end;
  //-----------
  W.EndWrite;
  W.SaveToFile(SaveFileName);
 finally
  W.Free;
 end;
end;

function TTxt2Rtf.PlainTextToRtf(Txt: string): string;
var
 W : TRtfWriter;
 Par: TmParser;
 Color: TStd16Color;
 Bold: Boolean;
begin
 try
  Par := TmParser.Create(Txt, False);
  W := TRtfWriter.Create;
  W.BeginWrite;
  //tkComment, tkIdentifier, tkInteger, tkFloat, tkConst, tkOperator, tkCommon, tkError
  Bold := False;
  Case Par.TokenType of
   tkComment                     : Color := sclMaroon;
   tkConst, tkInteger, tkFloat   : Color := sclRed;
   tkError                       : Color := sclNavy;
   tkOperator                    : Color := sclGreen;
   tkIdentifier, tkCommon        : begin
                                    if HasKey(Par.TokenString) then
                                    begin
                                     Color := sclBlue;
                                     Bold := True;
                                    end
                                    else
                                    begin
                                     Color := sclBlack;
                                     Bold := False;
                                    end;
                                   end;
  end;
  if Not NeedColor then Color := sclBlack;
  W.WriteText(Par.TokenString, Color, Bold);
  Par.NextToken;
  While Not Par.Eof do
  begin
   Bold := False;
   Case Par.TokenType of
    tkComment                     : Color := sclMaroon;
    tkConst, tkInteger, tkFloat   : Color := sclRed;
    tkError                       : Color := sclNavy;
    tkOperator                    : Color := sclGreen;
    tkIdentifier, tkCommon        : begin
                                     if HasKey(Par.TokenString) then
                                     begin
                                      Color := sclBlue;
                                      Bold := True;
                                     end
                                     else
                                     begin
                                      Color := sclBlack;
                                      Bold := False;
                                     end;
                                    end;
    //tkCrLn : Color := clBlack;
   end;
   if Not NeedColor then Color := sclBlack;
   W.WriteText(Par.TokenString, Color, Bold);
   Par.NextToken;
  end;
  //--------
  W.EndWrite;
  Result := W.RtfTxt;
 finally
  W.Free;
 end;
end;

procedure TTxt2Rtf.SetCaseSensitive(Sensitive: Boolean);
begin
 FCaseSensitive := Sensitive;
 FKeyWords.Sort;
end;

procedure TTxt2Rtf.SetKeyWord(Keys: TStringList);
begin
 FKeyWords.Assign(Keys);
 FKeyWords.CaseSensitive := KeyCaseSensitive;
 FKeyWords.Sort;
end;

end.