RichEdit 如果制作 DELPHI 代码编辑器的颜色效果！(4分)

呵呵，这问题有点难度啊。

不难不难，就是有点闪

我自己编了一个控件，如SUPERMMX所说，就是有点闪。呵呵。

?

或者有没有类似UltraEdit的编辑构件？

给你个例子看看：
{*******************************************************}
{ }
{ Delphi Helping Tools }
{ }
{ Copyright (c) 1996 Fabula Software info@fabula.com }
{ }
{*******************************************************}
unit SrcParser;
{ Miniparser for Syntax-Highlighting etc.
This code is usefull if you implement programmer tools
for example a source viewer or a documentation system.

You can use this unit to parse various languages like Pascal,
Java and C++. Each language have it's own parsing class
looking for identifiers and comments.

If you find a bug in the syntax parser for a language
please let me know. eMail the fix or bug to stefc@fabula.com
I only use Delphi so not wonder if the syntax scanning for Delphi
is the best

Projekt1.dpr, MiniParser.dfm & .pas demonstrate this unit.

You need a actual xProcs.dcu came from xTools package
for compile this. Look for our xTools-Nails & xTools-Screws
also !

If you enhance this unit with your own parser for your language
like Basic, Smalltalk, .... let me also known.

Stefan B鰐her, Fabula Software
}
interface

uses
Classes;

type
TParseState = (psNormal, psIdent, psKeyword, psNumber, psString, psComment );

type
TParser = class
private
FOnFound : TNotifyEvent;
FOnReplace: TNotifyEvent;
FState : TParseState;
FInput : String;
FSource : String;
FKeyWord : String;
FSelStart,
FSelEnd : Integer;
FComment : Integer;
FPrior : Boolean;
FIndex : Integer;
FKeywords: TStrings;
procedure SetKeywords(Value: TStrings);
protected
procedure Found; virtual;
procedure Mark;
procedure ParseChar(Ch,Next: Char; i: Integer); virtual; abstract;
procedure PushChar(Ch: Char);
function IsKeyword(const aKey: String): Boolean;
public
constructor Create;
destructor Destroy; override;
procedure HighLight(const Prefix, Postfix: String);
function Parse(const S: String): String; virtual;
property State : TParseState read FState;
property Input : String read FInput write FInput;
property Source : String read FSource write FSource;
property Keywords: TStrings read FKeywords write SetKeywords;
property OnFound: TNotifyEvent read FOnFound write FOnFound;
property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
end;

TPascalParser = class(TParser)
protected
procedure ParseChar(Ch, Next: Char; i: Integer); override;
public
constructor Create;
end;

TJavaParser = class(TParser)
protected
procedure ParseChar(Ch, Next: Char; i: Integer); override;
public
constructor Create;
end;

TCppParser = class(TParser)
protected
procedure ParseChar(Ch, Next: Char; i: Integer); override;
public
constructor Create;
end;

TDfmParser = class(TParser)
protected
procedure ParseChar(Ch, Next: Char; i: Integer); override;
public
constructor Create;
end;

TBasicParser = class(TParser)
end;

TSmalltalkParser = class(TParser)
end;

TBatchParser = class(TParser)
end;

TClipperParser = class(TParser)
end;

TSqlParser = class(TParser)
end;

{ .... }

function SourceToRtf(const aFile: String; aMono, aHeader: Boolean): String;

implementation

uses
xProcs, Windows, Graphics, SysUtils;

const
DIGIT = ['0'..'9'];
ALPHA = ['A'..'Z', 'a'..'z'];
IDENT = ALPHA + DIGIT + ['_'];

_Alpha : set of char = ['A'..'Z'];

constructor TParser.Create;
begin
inherited Create;
FKeywords:=TStringList.Create;
TStringList(FKeywords).Sorted:=True;
end;

destructor TParser.Destroy;
begin
FKeywords.Free;
inherited Destroy;
end;

procedure TParser.SetKeywords(Value: TStrings);
begin
FKeywords.Assign(Value);
end;

function TParser.IsKeyword(const aKey: String): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := FKeywords.Count-1;
while L <= H do
begin
I := (L + H) shr 1;
C := CompareText(FKeywords,aKey);
if C < 0 then L := I + 1 else
begin
H := I - 1;
if C = 0 then
begin
Result:=True;
break;
end;
end;
end;
end;


procedure TParser.HighLight(const Prefix, Postfix: String);
begin
Insert(Postfix,FSource,FSelEnd+1);
Insert(Prefix,FSource,FSelStart);
end;

function TParser.Parse(const S: String): String;
var
Ch,
Next: Char;
begin
FState := psNormal;
FSource:= '';
FInput := S;
Findex := 1;
while FIndex <= Length(FInput) do
begin
Ch := FInput[FIndex];
if FIndex < Length(FInput) then Next:=FInput[FIndex+1] else Next:=#0;
FSource := FSource + Ch;
if FState = psNormal then
FSelStart:=Length(FSource);
if Assigned(FOnReplace) then
FOnReplace(Self);
ParseChar(Ch,Next,FIndex);
Inc(FIndex);
end;
Result:=FSource;
end;

procedure TParser.PushChar(Ch: Char);
begin
FSource:=FSource+ Ch;
Inc(FIndex);
end;

procedure TParser.Found;
begin
if Assigned(FOnFound) then FOnFound(Self);
end;

procedure TParser.Mark;
begin
FPrior:=False;
end;

{ TPascalParser - Delphi &amp; Pascal Parser }

const
STRDELIM = '''';

constructor TPascalParser.Create;
const
_Keywords : array[1..70] of string =
('AND','ARRAY','AS','ASM','BEGIN','CASE','CLASS','CONST','CONSTRUCTOR','DESTRUCTOR',
'DIV','DO','DOWNTO','ELSE','END','EXCEPT','EXPORTS','FILE','FINALIZATION','FINALLY',
'FOR','FUNCTION','GOTO','IF','IMPLEMENTATION','INHERITED','INITIALIZATION',
'INLINE','INTERFACE','IS','LABEL','LIBRARY','MOD','NIL','NOT','OBJECT','OF','PACKED',
'PROCEDURE','PUBLIC','PUBLISHED','PROGRAM','PRIVATE','PROTECTED','PROPERTY','RAISE',
'RECORD','REPEAT','SET','SHL','SHR','STRING','THEN','THREADVAR','TRY',
'TYPE','UNIT','UNTIL','USES','WHILE','WITH','VAR','XOR',
'VIRTUAL','ABSTRACT','OVERRIDE','READ','WRITE','DEFAULT','INDEX' );
var
i : Integer;

begin
inherited Create;
for i:= Low(_Keywords) to High(_Keywords) do
FKeywords.Add(_Keywords);
end;

procedure TPascalParser.ParseChar(Ch, Next: Char; i: Integer);
begin
case FState of
psIdent :
if not (Ch in ALPHA+[ZERO..NINE,'_']) then
begin
FSelEnd:=Length(FSource)-1;
if IsKeyWord(FKeyWord) then
begin
FState := psKeyword;
Found;
{ here we should step into the second level of parsing }
end else
begin
{ push identifier into list of identifier }
Found;
end;
FState:=psNormal;
end else
FKeyword:=FKeyword+Upcase(Ch);

psNumber :
if not (Ch in [ZERO..NINE,'.','E','e']) then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal; { push number on stack }
end;

psString :
if Ch = STRDELIM then
if Next <> STRDELIM then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal; { push string on stack }
end;

psNormal :
case Ch of
SPACE,NULL,TAB,CR,LF : ; { null characters }

'>','<','=','[',']','+','-' : ; { operators }

ZERO..NINE : { numbers }
begin
FState:=psNumber;
end;

'#','$' :
if Next in DIGIT then { special numbers }
begin
FState:=psNumber;
Mark;
end;

'A'..'Z','a'..'z', '_' : { identifier }
begin
FState:=psIdent;
FKeyword:=Ch;
Mark;
end;

STRDELIM:
begin { string }
FState:=psString;
Mark;
end;

'{' : begin { (* comment }
FState:=psComment;
FComment:=1;
Mark;
end;

'(' : if Next = '*' then { { comment }
begin
FState:=psComment;
FComment:=2;
Mark;
end;

'/' : if Next = '/' then { // comment }
begin
FState:=psComment;
FComment:=3;
Mark;
end;
end;

psComment :

case FComment of
1 : if Ch = '}' then
begin
FSelEnd:=Length(FSource);
Found;
FState:=psNormal;
end;
2 : if Ch = '*' then
if Next = ')' then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal;
end;
3 : if Ch in [CR, LF] then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal;
end;
end;
end; { case state }
end;

{ TJavaParser - Java Parser }

constructor TJavaParser.Create;
const
_Keywords : array[1..59] of string = (
'ABSTRACT','BOOLEAN','BREAK','BYTE','CASE','CAST','CATCH','CHAR',
'CLASS','CONST','CONTINUE','DEFAULT','DO','DOUBLE','ELSE','EXTENDS',
'FINAL','FINALLY','FLOAT','FOR','FUTURE','GENERIC','GOTO','IF','IMPLEMENTS',
'IMPORT','INNER','INSTANCEOF','INT','INTERFACE','LONG','NATIVE','NEW',
'NULL','OPERATOR','OUTER','PACKAGE','PRIVATE','PROTECTED','PUBLIC',
'REST','RETURN','SHORT','STATIC','SUPER','SWITCH','SYNCHRONIZED','THIS',
'THROW','THROWS','TRANSIENT','TRY','VAR','VOID','VOLATILE','WHILE','BYVALUE',
'TRUE','FALSE' );

var
i : Integer;
begin
inherited Create;
for i:= Low(_Keywords) to High(_Keywords) do
FKeywords.Add(_Keywords);
end;

procedure TJavaParser.ParseChar(Ch, Next: Char; i: Integer);
begin
case FState of
psIdent :
if not (Ch in IDENT) then
begin
FSelEnd:=Length(FSource)-1;
if IsKeyWord(FKeyWord) then
begin
FState := psKeyword;
Found;
{ here we should step into the second level of parsing }
end else
begin
{ push identifier into list of identifier }
Found;
end;
FState:=psNormal;
end else
FKeyword:=FKeyword+Upcase(Ch);

psNumber :
if not (Ch in [ZERO..NINE,'.','E','e']) then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal; { push number on stack }
end;

psString :
if Ch = '"' then
if Next <>'"' then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal; { push string on stack }
end;

psNormal :
case Ch of
SPACE,NULL,TAB,CR,LF : ; { null characters }

'>','<','=','[',']','+','-' : ; { operators }

ZERO..NINE : { numbers }
begin
FState:=psNumber;
end;

'#','$' :
if Next in DIGIT then { special numbers }
begin
FState:=psNumber;
Mark;
end;

'A'..'Z', 'a'..'z', '_' : { identifier }
begin
FState:=psIdent;
FKeyword:=Ch;
Mark;
end;

'"' : begin { string }
FState:=psString;
Mark;
end;

'/' : if Next = '/' then { // &amp; /* comment }
begin
FState:=psComment;
FComment:=3;
Mark;
end else if Next = '*' then
begin
FState:=psComment;
FComment:=2;
Mark;
end;
end;

psComment :

case FComment of
1 : ;
2 : if Ch = '*' then
if Next = '/' then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal;
end;
3 : if Ch in [CR, LF] then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal;
end;
end;
end; { case state }
end;

{ TCppParser - C++ Source parser }

constructor TCppParser.Create;
const
_Keywords : array[1..107] of string = (
'__ASM','__CDECL','__CS','__DECLSPEC','__DS','__ES','__EXCEPT','__EXPORT',
'__FAR','__FASTCALL','__FASTTHIS','__FINALLY','__HUGE','__IMPORT',
'__INTERRUPT','__LOADDS','__NEAR','__PASCAL','__RTTI','__SAVEREGS',
'__SEG','__SLOWTHIS','__SS','__TRY','_ASM','_CDECL','_CS','_DS','_ES',
'_EXPORT','_FAR','_FASTCALL','_HUGE','_IMPORT','_INTERRUPT','_LOADDS',
'_NEAR','_PASCAL','_SAVEREGS','_SEG','_SS','ASM','AUTO','BOOL','BREAK',
'CASE','CATCH','CDECL','CHAR','CLASS','CONST','CONST_CAST','CONTINUE',
'DEFAULT','DELETE','DO','DOUBLE','DYNAMIC_CAST','ELSE','ENUM','EXTERN',
'FALSE','FAR','FLOAT','FOR','FRIEND','GOTO','HUGE','IF','INLINE','INT',
'INTERRUPT','LONG','MUTABLE','NAMESPACE','NEAR','NEW','OPERATOR','PASCAL',
'PRIVATE','PROTECTED','PUBLIC','REGISTER','REINTERPRET_CAST','RETURN',
'SHORT','SIGNED','SIZEOF','STATIC','STATIC_CAST','STRUCT','SWITCH','TEMPLATE',
'THIS','THROW','TRUE','TRY','TYPEDEF','TYPEID','UNION','UNSIGNED','USING',
'VIRTUAL','VOID','VOLATILE','WCHAR_T','WHILE' );
var
i : Integer;
begin
inherited Create;
for i:= Low(_Keywords) to High(_Keywords) do
FKeywords.Add(_Keywords);
end;

procedure TCppParser.ParseChar(Ch, Next: Char; i: Integer);
begin
case FState of
psIdent :
if not (Ch in IDENT ) then
begin
FSelEnd:=Length(FSource)-1;
if IsKeyWord(FKeyWord) then
begin
FState := psKeyword;
Found;
{ here we should step into the second level of parsing }
end else
begin
{ push identifier into list of identifier }
Found;
end;
FState:=psNormal;
end else
FKeyword:=FKeyword+Upcase(Ch);

psNumber :
if not (Ch in [ZERO..NINE,'.','E','e']) then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal; { push number on stack }
end;

psString :
if Ch = '"' then
if Next <>'"' then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal; { push string on stack }
end;

psNormal :
case Ch of
SPACE,NULL,TAB,CR,LF : ; { null characters }

'>','<','=','[',']','+','-' : ; { operators }

ZERO..NINE : { numbers }
begin
FState:=psNumber;
end;

'#','$' :
if Next in DIGIT then { special numbers }
begin
FState:=psNumber;
Mark;
end;

'A'..'Z', 'a'..'z', '_' : { identifier }
begin
FState:=psIdent;
FKeyword:=Ch;
Mark;
end;

'"' : begin { string }
FState:=psString;
Mark;
end;

'/' : if Next = '/' then { // &amp; /* comment }
begin
FState:=psComment;
FComment:=3;
Mark;
end else if Next = '*' then
begin
FState:=psComment;
FComment:=2;
Mark;
end;
end;

psComment :

case FComment of
1 : ;
2 : if Ch = '*' then
if Next = '/' then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal;
end;
3 : if Ch in [CR, LF] then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal;
end;
end;
end; { case state }
end;

{ TDfmParser - Delphi Form as Text }

constructor TDfmParser.Create;
const
_Keywords : array[1..2] of string = ( 'END', 'OBJECT' );
var
i : Integer;
begin
inherited Create;
for i:= Low(_Keywords) to High(_Keywords) do
FKeywords.Add(_Keywords);
end;

procedure TDfmParser.ParseChar(Ch, Next: Char; i: Integer);
begin
case FState of
psIdent :
if not (Ch in IDENT ) then
begin
FSelEnd:=Length(FSource)-1;
if IsKeyWord(FKeyWord) then
begin
FState := psKeyword;
Found;
{ here we should step into the second level of parsing }
end else
begin
{ push identifier into list of identifier }
Found;
end;
FState:=psNormal;
end else
FKeyword:=FKeyword+Upcase(Ch);

psNumber :
if not (Ch in [ZERO..NINE,'.','E','e']) then
begin
FSelEnd:=Length(FSource)-1;
Found;
FState:=psNormal; { push number on stack }
end;

psString :
if Ch = '''' then
if Next <>'''' then
begin
PushChar(Next);
FSelEnd:=Length(FSource);
Found;
FState:=psNormal; { push string on stack }
end;

psNormal :
case Ch of
SPACE,NULL,TAB,CR,LF : ; { null characters }

'>','<','=','[',']','+','-' : ; { operators }

ZERO..NINE : { numbers }
begin
FState:=psNumber;
end;

'#','$' :
if Next in DIGIT then { special numbers }
begin
FState:=psNumber;
Mark;
end;

'A'..'Z', 'a'..'z', '_' : { identifier }
begin
FState:=psIdent;
FKeyword:=Ch;
Mark;
end;

STRDELIM :
begin { string }
FState:=psString;
Mark;
end;
end;

end; { case state }
end;

type
TParserCallBack = class
class procedure FoundColor(Sender: TObject);
class procedure FoundMono(Sender: TObject);
class procedure Replace(Sender: TObject);
end;

class procedure TParserCallBack.FoundColor(Sender: TObject);
var
aParser : TParser;
begin
aParser := Sender as TParser;
case aParser.State of
psKeyword : aParser.HighLight('{/cf1/b ','}'); { white bold }
psComment : aParser.HighLight('{/cf3/i ','}'); { gray italic}
end;
end;

class procedure TParserCallBack.FoundMono(Sender: TObject);
var
aParser : TParser;
begin
aParser := Sender as TParser;
case aParser.State of
psKeyword : aParser.HighLight('{/b ','}'); { bold }
psComment : aParser.HighLight('{/i ','}'); { italic}
end;
end;

class procedure TParserCallBack.Replace(Sender: TObject);
var
aParser : TParser;
Ch : Char;
S: String;
begin
aParser := Sender as TParser;
S := aParser.Source;
Ch := S[Length(S)];
case Ch of
'{' : Insert('/',S,Length(S));
'}' : Insert('/',S,Length(S));
LF : Insert('/par ',S,Length(S));
else exit;
end;
aParser.Source:=S;
end;

{ converts a Delphi TColor into a RTF-color table string }
function ColorToRtf(aColor:TColor): String;
begin
aColor:=ColorToRGB(aColor);
Result:='/red'+IntToStr(GetRValue(aColor))+
'/green'+IntToStr(GetGValue(aColor))+
'/blue'+IntToStr(GetBValue(aColor))+';';
end;

{ Load a delphi form file as text }
function dfmFileLoad(const aFile: String): String;
var
aInput : TStream;
aOutput : TStream;
aStr : TStrings;
begin
Result := '';
aInput := TFileStream.Create(aFile, fmOpenRead);
try
aOutput := TMemoryStream.Create;
try
ObjectResourceToText(aInput,aOutput);

aOutput.Position:=0;

aStr:=TStringList.Create;
try
aStr.LoadFromStream(aOutput);
Result:=aStr.Text;
finally
aStr.Free;
end;

finally
aOutput.Free;
end;
finally
aInput.Free;
end;
end;

{ converts a source file to a RTF-String that can be displayed or not }
function SourceToRtf(const aFile: String; aMono,aHeader: Boolean): String;
var
aParser : TParser;
aExt : String[10];
RtfHeader : String;
begin
RtfHeader :=
'{/rtf1/ansi/deff0/deftab720'
+'{/fonttbl'
+'{/f0/fmodern Courier New;}}'
+'{/colortbl'+
ColorToRtf(clBlack)+
ColorToRtf(clWhite);

if not aMono then { add yellow and silver }
RtfHeader := RtfHeader +
ColorToRtf(clYellow)+
ColorToRtf(clSilver);

RtfHeader:=RtfHeader +'}' +'/deflang1031/pard/plain/f0/fs20';

if not aMono then RtfHeader:= RtfHeader + '/cf2'; { yellow as default }

aExt:=LowerCase(ExtractFileExt(aFile));
if Pos(aExt,'*.pas;*.dpr;*.int;*.inc') > 0 then
aParser := TPascalParser.Create
else if Pos(aExt,'*.c;*.cpp;*.h') > 0 then
aParser := TCppParser.Create
else if Pos(aExt,'*.java') > 0 then
aParser := TJavaParser.Create
else if Pos(aExt,'*.dfm') > 0 then
aParser := TDfmParser.Create
else
raise Exception.Create('Unknown source yet !');

if aParser is TDfmParser then
Result:= dfmFileLoad(aFile)
else
Result:= strFileLoad(aFile);

try
with TParserCallBack do begin
if aMono then
aParser.OnFound:= FoundMono
else
aParser.OnFound:= FoundColor;
aParser.OnReplace := Replace;
end;

Result := aParser.Parse(Result);
if aHeader then
Result := RtfHeader+Result+'}';
finally
aParser.Free;
end;
end;

end.

用了好几口气也看不完

接受答案了.