rtfexport.~pas

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

{*******************************************************}
{                                                       }
{       TTxt2Rtf  v1.0                                  }
{       Email: [e-mail]                      }
{       free                                            }
{       Copyright (c) 2002.7 chenliping, China          }
{                                                       }
{*******************************************************}


unit RtfExport;

interface

uses
  Windows, SysUtils, Classes, Graphics, Dialogs, ShellApi, Forms;

Const
 CrLn = Chr(13) + Chr(10);
 Head = '{\rtf1\ansi\ansicpg936\deff0\deflang1033\deflangfe2052{\fonttbl{\f0\fmodern\fprq6\fcharset134 \''cb\''ce\''cc\''e5;}}' +
        '{\colortbl ;\red0\green0\blue0;\red128\green0\blue0;\red0\green128\blue0;\red128\green128\blue0;\red0\green0\blue128;\red128\' +
        'green0\blue128;\red0\green128\blue128;\red128\green128\blue128;\red192\green192\blue192;\red255\green0\blue0;\red0\green255\blue0;\red255' +
        '\green255\blue0;\red0\green0\blue255;\red255\green0\blue255;\red0\green255\blue255;\red255\green255\blue255;}' + CrLn +
        '\viewkind4\uc1\lang2052\pard\cf1\f0\fs20 ';

 RCrLn = '\par' + CrLn;
 Tail = '\lang2052\f1\par}';

Type
 TSQLToken = (stSymbol, stQuotedSymbol, stString, stDelimitier, stParameter,
    stNumber, stComment, stComma, stPeriod, stEQ, stLParen, stRParen, stOther,
    stEnd);

 TSQLTokenTypes = set of TSQLToken;

 TCommentType = (ctMultiLine, ctLineEnd);

 TTokenType = (tkComment, tkIdentifier, tkInteger, tkFloat, tkConst, tkOperator, tkCommon, tkError, tkCrLn);

 TmParser = class
 private
  FTxt: string;
  FTokenString: string;
  FBufBeg, FBufEnd, FTokenBegin, FTokenEnd: PChar;
  FTokenType: TTokenType;
  FTokenPos: Integer;
  FTokenLine: Integer;
  FEof: Boolean;
 protected
 public
  Constructor Create(ATxt: string; IsFileName: Boolean); overload;
  procedure NextToken;
  property Eof: Boolean read FEof;
  property TokenType: TTokenType read FTokenType;
  property Txt: string read FTxt;
  property TokenPos: Integer read FTokenPos;
  property TokenString: string read FtokenString;
  property TokenLine: Integer read FTokenLine;
 end;

 TStd16Color = (sclBlack, sclMaroon, sclGreen, sclOlive, sclNavy,
                sclPurple, sclTeal, sclGray, sclSilver, sclRed,
                sclLime, sclYellow, sclBlue, sclFuchsia, sclAqua, sclWhite);

 TRtfWriter = class
 private
  FMem: TMemoryStream;
  FList: TStringList;
  function ProcessText(Txt: string): String;
  procedure WriteReturn;
  procedure Write(Txt: string);
 public
  constructor Create;
  destructor Destroy; override;
  procedure BeginWrite;
  procedure WriteText(Txt: string; Color: TStd16Color; Bold: Boolean);
  procedure EndWrite;
  procedure SaveToFile(FileName: string);
  function RtfTxt: string;
 end;

 TTxt2Rtf = class
 private
  FNeedColor: Boolean;
  FCommentColor: TColor;
  FKeyWords: TStringList;
  FCaseSensitive: Boolean;
  procedure SetKeyWord(Keys: TStringList);
  procedure SetCaseSensitive(Sensitive: Boolean);
  function HasKey(Keyword: string): Boolean;
 public
  constructor Create;
  destructor Destroy; override;
  function PlainTextToRtf(Txt: string): string;
  procedure SaveTextToRtfFile(Txt, SaveFileName: string);
  property KeyWords: TStringList read FKeyWords write SetKeyWord;
  property KeyCaseSensitive : Boolean read FCaseSensitive write SetCaseSensitive;
  property NeedColor: Boolean read FNeedColor write FNeedColor;
 end;

implementation

//TmParser.
Constructor TmParser.Create(ATxt: string; IsFileName: Boolean);
var
 Str: TFileStream;
begin
 if Not IsFileName then
  FTxt := ATxt
 else
 begin
  try
   try
    Str := TFileStream.Create(ATxt, fmOpenRead or fmShareDenyWrite);
    Str.Position := 0;
    SetLength(Ftxt, Str.Size);
    Str.Read(FTxt[1], Str.Size);
   except
    Raise Exception.Create(ATxt + ' File not Exists');
   end;
  finally
   Str.Free;
  end;
 end;
 FBufBeg := @FTxt[1];
 FBufEnd := FBufBeg + Length(FTxt);
 FTokenBegin := FBufBeg;
 FTokenEnd := FTokenBegin;
 NextToken;
 FEof := False;
 FTokenLine := 0;
end;

procedure TmParser.NextToken;
var
 Ch: Char;
 P : PChar;
 Tmp: string;
 Level: Integer;
 IsConst: Boolean;
begin
 FTokenString := '';
 FTokenBegin := FTokenEnd;
 if Not FEof then
 Case FTokenEnd^ of
  Chr(0): FEof := True;
  '<', '[', ')', ']', '>', ';', ':', ',', '.', '=', '\',
  '|', '!', '?', '&', '%', '#', '@', '^', '~',
  ' ':  begin Inc(FTokenEnd); FTokenType := tkOperator; end;
  Chr(10): begin Inc(FTokenEnd); NextToken; end;             //Skip
  Chr(13): begin Inc(FTokenEnd); Inc(FTokenLine); FTokenType := tkCrLn; end; //Process LineNo
  '''', '"': begin                   //Const String
              Ch := FTokenEnd^;
              Inc(FTokenEnd);
              FTokenType := tkConst;
              //找下一个'
              While FTokenEnd^ <> Ch do
              begin
               Case FTokenEnd^ of
                Chr(13): begin Inc(FTokenLine); FTokenType := tkError; Break; end;
                Chr(0) : begin Inc(FTokenLine); FEof := True; FTokenType := tkError; Break; end;
               end;
               Inc(FTokenEnd);
              end;
              if FTokenEnd^ = Ch then Inc(FTokenEnd);
            end;
  '{' :  begin      //Block comment
          Inc(FTokenEnd);
          Level := 1;
          IsConst := False;
          FTokenType := tkComment;
          While True do
          begin
           Case FTokenEnd^ of
            #13: Inc(FTokenLine);
            #0 : begin Inc(FTokenLine); FEof := True; FTokenType := tkError; Break; end;
            // {a = '{' }, {a = '}'}:        //Not count '{', '}' in constant string
            '''': IsConst := Not IsConst;
            '{': if Not IsConst then Inc(Level);
            '}': if Not IsConst then begin Dec(Level); if(Level <= 0) then begin Inc(FTokenEnd); Break; end; end;
           end;
          Inc(FTokenEnd);
          end;
         end;
  '(': begin                        //line comment flag
        Inc(FTokenEnd);
        FTokenType := tkOperator;
        if FTokenEnd^ = '*' then
        begin
         Inc(FTokenEnd);
         Level := 1;
         IsConst := False;
         FTokenType := tkComment;
         While True do
         begin
          Case FTokenEnd^ of
           Chr(13): Inc(FTokenLine);
           Chr(0):  begin Inc(FTokenLine); FTokenType := tkError; Break; FEof := True; end;
           ''''  : IsConst := Not IsConst;           //Not supoort "
           '(' : begin
                  if Not IsConst then
                  if (FBufEnd - FTokenEnd - 1 >= 0) then
                   if (FTokenEnd+1)^ = '*' then
                   begin
                    Inc(Level);
                    Inc(FTokenEnd);
                   end;
                 end;
           '*'   : begin    //Find *---End find flag
                    if Not IsConst then
                    if (FBufEnd - FTokenEnd - 1 >= 0) then
                     if (FTokenEnd+1)^ = ')' then
                     begin
                      Dec(Level);
                      Inc(FTokenEnd);
                     end;
                   end;
          end;   //end Case
          Inc(FTokenEnd);
          if (Level <= 0) then begin Level := 0; Break; end;
         end; //End While
         if Level <> 0 then FTokenType := tkError;
        end;  //End If
       end;
  '/': begin            //line comment flag
        Inc(FTokenEnd);
        FTokenType := tkOperator;
        //   /*处理
        if FTokenEnd^ = '*' then
        begin
         Inc(FTokenEnd);
         Level := 1;
         IsConst := False;
         FTokenType := tkComment;
         While True do
         begin
          Case FTokenEnd^ of
           Chr(13): Inc(FTokenLine);
           Chr(0):  begin Inc(FTokenLine); FTokenType := tkError; Break; FEof := True; end;
           ''''  : IsConst := Not IsConst;
           '/' : begin
                  if Not IsConst then
                  if (FBufEnd - FTokenEnd - 1 >= 0) then
                   if (FTokenEnd+1)^ = '*' then
                   begin
                    Inc(Level);
                    Inc(FTokenEnd);
                   end;
                 end;
           '*'   : begin    //Find *----End find flag
                    if Not IsConst then
                    if (FBufEnd - FTokenEnd - 1 >= 0) then
                     if (FTokenEnd+1)^ = '/' then
                     begin
                      Dec(Level);
                      Inc(FTokenEnd);
                     end;
                   end;
          end;   //end Case
          Inc(FTokenEnd);
          if (Level <= 0) then begin Level := 0; Break; end;
         end; //End While
         if Level <> 0 then FTokenType := tkError;
        end;  //End If
        //--------------//
        if FTokenEnd^ = '/' then
        begin
         FTokenType := tkComment;
         Inc(FTokenEnd);
         While Not (FTokenEnd^ in [#13,#0]) do Inc(FTokenEnd);
        end;
       end;
  '-': begin            //Line comment: --, in order to compatible with Standard SQL92
        Inc(FTokenEnd);
        if FTokenEnd^ = '-' then
        begin
         FTokenType := tkComment;
         While True do
         begin
          Case FTokenEnd^ of
           Chr(13): begin Inc(FTokenLine); Break; end;
           Chr(0) : begin Inc(FTokenLine); FEof := True; break; end;
          end;
          Inc(FTokenEnd);
         end;
        end;
       end;
   'A'..'Z', 'a'..'z', '_', #127..#255:    //#127..#255, non-English Character
    begin
      Inc(FTokenEnd);
      while FTokenEnd^ in ['A'..'Z', 'a'..'z', '0'..'9', '_', '$', '@', #127..#255] do Inc(FTokenEnd);
      FTokenType := tkIdentifier;
    end;
  '0'..'9':
    begin
      Inc(FTokenEnd);
      while FTokenEnd^ in ['0'..'9'] do Inc(FTokenEnd);
      FTokenType := tkInteger;
      while FTokenEnd^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
      begin
        Inc(FTokenEnd);
        FTokenType := tkFloat;
      end;
      if (FTokenEnd^ in ['c', 'C', 'd', 'D', 's', 'S']) then
      begin
        FTokenType := tkFloat;
        Inc(FTokenEnd);
      end;
    end;
  else
  begin
   //Other Characters