代码即时高亮源码，Delphi 实现

 1、配置文件

<?xml version="1.0" encoding="utf-8" > < Classify> < Language Name="Delphi"> < Item Name="注释"> < Color>255</Color> < Words>AND</Words> < /Item> < Item Name="注释"> < Color>8388608</Color> < Words>UNIT;FOR;ELSE;SENDER;TOBJECT;TO;NOT;IF;THEN;DO;APPLICATION;PROCEDURE;FUNCTION;IMPLEMENTATION;BEGIN;END;PRIVATE;VAR;USES;TYPE;INTERFACE;PUBLIC;OR;OF;INHERITED;CLASS;PROTECTED;PUBLISHED;READ;WRITE;STRING;INTEGER;CHAR;FLOAT;DOUBLE;CARDINAL;NIL;CONST;WITH;RAISE;EXCEPT;TRY;EXCEPTION;PROPERTY;CONTRUCTOR;DESTRUCTOR;OVERRIDE;RECORD;DIV</Words> < /Item> < /Language> < /Classify>

 

 

2、EventMessages.pas

unit EventMessages; interface Const FileNotFound:String = '文件 %s 未找到,请重新确认文件路径。 '; XmlNodeNotFound:String = 'Xml结点 %s 未找到,请检查Xml文件的正确性。 '; XmlReadError:String = '读取Xml配置文件 %s 时发生错误,请检查文件的正确性。 '; LanguageNil:String = '要添加的新程序设计语言名称不能为空白! '; LanguageExist:String = '要添加的程序设计语言 %s 已经存在。 '; implementation end.

 

 

3、HighLightEditor.pas

unit HighLightEditor; interface uses Windows,Messages,Classes,StdCtrls,Forms,SyntaxHighlighter,Graphics,SysUtils, XmlMapper; type THighLightEditor = class(TMemo) private FProgramLanguage: String; FXmlFile:String;//配置文件路径 FRect,MaskRect:TRect; FDC:HDC; FHighLightor:TSyntaxHighlighter; FXmlMapper:TXmlMapper; Flanguages:TStrings; procedure SetProgramLanguage(const Value: String); Function FirstVisibleLine():Integer; Function VisibledLines():Integer; procedure SetXmlFile(const Value: String); protected procedure WndProc(var message:Tmessage);override; Procedure CreateWnd();Override; //Create与Destrly要成对出现 Procedure DestroyWnd;Override; public { Public declarations } published Constructor Create(AOwner:TComponent);Override;//Create与Destrly要成对出现 Destructor Destroy;Override; Property ProgramLanguage:String read FProgramLanguage write SetProgramLanguage; Property XmlFile:String read FXmlFile write SetXmlFile; Property Languages:TStrings read Flanguages;//这是个集合 Procedure ShowSchemaEditor(); end; procedure Register; implementation uses EventMessages,SchemaEditor,unit1; procedure Register; begin RegisterComponents('HighLightEditor', [THighLightEditor]); end; { THighLightEditor } constructor THighLightEditor.Create(AOwner: TComponent); begin inherited Create(AOwner); BorderStyle:=bsNone; Font.Name:='Courier New'; Font.Size:=10; Scrollbars:=ssBoth; end; procedure THighLightEditor.CreateWnd; begin inherited; FDC:=GetDc(Handle); FHighLightor:=TSyntaxHighlighter.Create(Handle,FDC); end; destructor THighLightEditor.Destroy; begin Parent:=nil; //ReleaseDC(Handle,FDC); FreeAndNil(FHighLightor); FreeAndNil(FXmlMapper); //Flanguages.Free; //这个没有显示创建，所以不用手动释放 inherited; end; procedure THighLightEditor.DestroyWnd; begin //ReleaseDC(Handle,FDC); inherited; end; function THighLightEditor.FirstVisibleLine: Integer; begin Result:=SendMessage(Handle,EM_GETFIRSTVISIBLELINE,0,0); end; procedure THighLightEditor.SetProgramLanguage(const Value: String); begin FProgramLanguage := Value; FXmlMapper.Language:=FProgramLanguage; Repaint; end; procedure THighLightEditor.SetXmlFile(const Value: String); begin if not FileExists(Value) then Raise Exception.Create(Format(FileNotFound,[Value]))//到这里后就不会再运行 else begin FXmlFile := Value; if Assigned(FXmlMapper) then FreeAndNil(FXmlMapper); FXmlMapper:=TXmlMapper.Create(FXmlFile); Flanguages:=FXmlMapper.Languages; FHighLightor.HighLightSchema:=FXmlMapper.Schema; end; end; procedure THighLightEditor.ShowSchemaEditor; begin //SchemaEditorFrm:=TSchemaEditorFrm.Create(Self,FProgramLanguage); //SchemaEditorFrm.ShowModal; end; function THighLightEditor.VisibledLines: Integer; Var OldFont:HFont; TM:TTextMetric; begin OldFont:=SelectObject(FDC,Font.Handle); GetTextMetrics(FDC,TM); Result:=(FRect.Bottom-FRect.Top) div (TM.tmHeight + TM.tmExternalLeading); SelectObject(Handle,OldFont); end; procedure THighLightEditor.WndProc(var Message: TMessage); Var FirstLine,CharIndex,LastLine,I:Integer; TokenArray:TKeyWordsArray; WordsToHightLight:String; HighLightFont:TFont; MaskRectHandle:THandle; LeftLines:Integer;//剩余行数 //FSelectionToAvoid:TSelection; {$Region '取得首个字符的索引'} function FirstCharIndex: Integer; begin Result:=SendMessage(Handle,EM_LINEINDEX,FirstLine,0); end; {$EndRegion} {$Region ' 为高亮准备'} Procedure BeginPaint(); Var HighLightFontHandle:HFont; begin HighLightFont:=TFont.Create; With Self,HighLightFont do //with用法 变量的宿主在常量的左边 begin Name:=Font.Name; Size:=Font.Size; Style:=Font.Style+[fsBold]; HighLightFontHandle:=HighLightFont.Handle; //看下在省略font时的handle end; SelectObject(FDC,HighLightFontHandle); SetBkMode(FDC,TRANSPARENT);//背景色为透明 with MaskRect do begin Left:=FRect.Left; Top:=FRect.Top; Right:=FRect.Right; Bottom:=FRect.Bottom; MaskRectHandle:=CreateRectRgn(Left,Top,Right,Bottom); end; SelectObject(FDC,MaskRectHandle); HideCaret(Handle); end; {$Endregion} {$Region ' 结束高亮'} Procedure EndPaint(); begin ShowCaret(Handle); FreeAndNil(HighLightFont); DeleteObject(MaskRectHandle); end; {$Endregion} {$Region ' 具体高亮部分'} Procedure HightLighting(); Var I:Integer; WordMetric:PSize;//宽度和高度 begin for I := 0 to High(TokenArray^) do begin New(WordMetric); with TokenArray^[i] do begin SetTextColor(FDC,MaskColor);//设置字体颜色 TextOut(FDC,WordCoordinate.X,WordCoordinate.Y,PAnsiChar(WordToHightLigth),Length(WordToHightLigth)); end; Dispose(WordMetric); end; end; {$EndRegion} begin {$Region ' 主体'} inherited; case Message.Msg of WM_KEYUP,WM_Paint,WM_LBUTTONDOWN,WM_RBUTTONDOWN: begin //defaulthandler(Message); if (ProgramLanguage='') then //or (Lines.Count=0) or (Message.WParam<>VK_SPACE) then exit else begin SendMessage(Handle,EM_GETRECT,0,Integer(@FRect));//取得外框 FirstLine:=FirstVisibleLine; LeftLines:=Lines.Count-(FirstLine+1);//当前的行号从0开始，所以加1 CharIndex:=FirstCharIndex;//取得首行首字索引 if LeftLines<(VisibledLines-1) then//如果剩余行数小余可见行（可见行包括FirstLine,所以减1） LastLine:=FirstLine+LeftLines else LastLine:=FirstLine+(VisibledLines-1); for I := FirstLine to LastLine do WordsToHightLight:=WordsToHightLight+Lines[i]+#13+#10; TokenArray:=FHighLightor.SplitLine(PChar(WordsToHightLight),CharIndex); if Not Assigned(TokenArray) then exit; BeginPaint; HightLighting; EndPaint; Dispose(TokenArray); defaulthandler(Message); end; end; end; {$Endregion} end; end.

 

 

4、HighLightSchemaClass.pas

unit HighLightSchemaClass; interface uses Windows,Graphics,SysUtils; Const MaxListSize = Maxint div 16; Type TItem=Record FKeyWord:Array of String; FMaskColor:TColor; End; TIndexSort=Set of 65..90; PItemList=^TItemList; TItemList=Array[0..MaxListSize] of TItem; //两种定义数组的方法 Type THighLightSchema = Class //仿TStringList private FItemCount:integer; FMeasureCount:integer; FItemList:PItemList; //数组指针 FIndexSort:TIndexSort; procedure IncreaseMeasure(); Procedure SetMeasure(Const NewMeasure:integer); Function GetItemCount():integer; public Constructor Create(); Destructor Destroy();Override; Procedure Clear(); Function Find(Word:PChar;Var Color:TColor):Boolean; //Function CheckIndex(WordChar:PChar):Boolean; Procedure AddItem(Word:String;Color:String); Property Count:integer Read GetItemCount; Property IndexSort:TIndexSort Read FIndexSort; end; implementation { HighLightSchema } {$Region ' 添加,关键字部分在一个动态数组里'} procedure THighLightSchema.AddItem(Word:String;Color:String); var i,j:integer; begin if FItemCount=FMeasureCount then IncreaseMeasure; With FItemList^[FItemCount] do begin Pointer(FMaskColor):=nil; Pointer(FKeyWord):=nil; FMaskColor:=StrToInt(Color); j:=Pos(';',Word); while j>0 do begin i:=High(FKeyWord)+1; inc(i); SetLength(FKeyWord,i); FIndexSort:=FIndexSort+[ord(Word[1])]; FKeyWord[i-1]:=Copy(Word,1,j-1); Delete(Word,1,j); j:=Pos(';',Word); end; if Word<>'' then begin i:=High(FKeyWord)+1; inc(i); SetLength(FKeyWord,i); FKeyWord[i-1]:=Word; FIndexSort:=FIndexSort+[ord(Word[1])]; end; end; inc(FItemCount); end; {$Endregion} {$Region ' 在进行添加之前要先 Clear'} //function THighLightSchema.CheckIndex(WordChar: PChar): Boolean; //var // s:String; //begin // Result:=false; // s:=UpperCase(WordChar); // if Ord(s[1]) in FIndexSort then Result:=true; //end; procedure THighLightSchema.Clear; begin if FItemCount <> 0 then begin Finalize(FItemList^[0], FItemCount); FItemCount := 0; SetMeasure(0); end; end; {$EndRegion} constructor THighLightSchema.Create; begin FItemCount:=0; FMeasureCount:=0; end; destructor THighLightSchema.Destroy; begin inherited Destroy; if FItemCount <> 0 then Finalize(FItemList^[0], FItemCount); FItemCount := 0; SetMeasure(0); end; {$Region ' 具体的查找部分，如果有则返回真，并取颜色值'} function THighLightSchema.Find(Word:PChar;Var Color:TColor): Boolean; var I,j:Integer; begin Result := False; for I := 0 to FItemCount - 1 do begin if Result then break; with FItemList^[I] do begin for j := 0 to High(FKeyWord) do if SameText(FKeyWord[j],Word) then begin Result:=true; Color:=FMaskColor; Break; end; end; end; end; {$Endregion} function THighLightSchema.GetItemCount: integer; begin Result:=FItemCount; end; procedure THighLightSchema.IncreaseMeasure; var Delta: Integer; begin if FMeasureCount > 64 then Delta := FMeasureCount div 4 else if FMeasureCount > 8 then Delta := 16 else Delta := 4; SetMeasure(FMeasureCount+Delta); end; procedure THighLightSchema.SetMeasure(const NewMeasure: integer); begin ReallocMem(FItemList, NewMeasure * SizeOf(TItem)); FMeasureCount := NewMeasure; end; end.

 

 

5、Syntaxhighlighter.pas

unit SyntaxHighlighter; interface uses Windows,Messages,Classes,SysUtils,StdCtrls,Types,Graphics,HighLightSchemaClass; Type {$Region ' 定义一个记录（结构）用于高亮的词的相关信息'} HightLightInfor=Record WordToHightLigth:String;//要高亮的词 WordCoordinate:TPoint;//坐标 左上角 MaskColor:TColor;//指向颜色的指针 End; TKeyWordsArray=^KeyWordsArray; KeyWordsArray=Array of HightLightInfor; {$Endregion} TSelection=Record iStart:Integer; iEnd:Integer; End; //TProcessType=(pNumber,pComment,pKeyWord); TSyntaxHighlighter=Class private FSplitString:String; {$Region ' Editor'} FEditorHandle:THandle; FEditorRect:TRect; FEditorDC: HDC; FHighLightSchema: THighLightSchema; FSelectionToAvoid: TSelection; {$EndRegion} {$Region ' 属性方法'} //procedure SetComment(const Value: String); procedure SetSplitString(const Value: String); procedure SetEditorRect(const Value: TRect); procedure SetHighLightSchema(const Value: THighLightSchema); procedure SetSelectionToAvoid(const Value: TSelection); {$EndRegion} Public {$Region ' 构造函数'} Constructor Create(EditorHandle:THandle;DC:HDC); Destructor Destroy();Override; {$EndRegion} {$Region ' 对外属性'} Property SplitString:String read FSplitString write SetSplitString; //Property Comment:String read FComment write SetComment; Property EditorRect:TRect write SetEditorRect; {$EndRegion} Function SplitLine(LineString:PChar;Const CharIndex:Integer=0):TKeyWordsArray; Property HighLightSchema:THighLightSchema write SetHighLightSchema; Property SelectionToAvoid:TSelection write SetSelectionToAvoid; End; implementation { TSyntaxHighlighter } {$Region ' 构造函数'} constructor TSyntaxHighlighter.Create(EditorHandle:THandle;DC:HDC); begin FEditorHandle:=EditorHandle;//取得句柄 FEditorDC:=DC; end; destructor TSyntaxHighlighter.Destroy; begin inherited; end; {$EndRegion} {$region ' 属性过程'} //procedure TSyntaxHighlighter.SetComment(const Value: String); //begin // FComment := Value; //end; procedure TSyntaxHighlighter.SetEditorRect(const Value: TRect); begin FEditorRect := Value; end; procedure TSyntaxHighlighter.SetHighLightSchema(const Value: THighLightSchema); begin FHighLightSchema := Value; end; procedure TSyntaxHighlighter.SetSelectionToAvoid(const Value: TSelection); begin FSelectionToAvoid := Value; end; procedure TSyntaxHighlighter.SetSplitString(const Value: String); begin FSplitString := Value; end; {$endregion} //指向string的指针 function TSyntaxHighlighter.SplitLine(LineString: PChar;Const CharIndex:Integer): TKeyWordsArray; {$Region ' 函数主体'} Var FWord:String; FirstChar:String;//一个单词的首字,然后用它去匹配，看是否有这个词的高亮字 FirstPos,Index:Integer;//首字的索引 Searching:Boolean;//在出现首字之后置为真，在遇到分隔符后置为假 ,或在高亮字中无这个字 FWordBeing:Boolean;//标识一个新的词开始了,在开始查找之后为true,完成一个词后为false {$Region ' 具体查找是否需要高亮,子过程（可共用主[父]函数的变量）'} Procedure Processing(toWord:PChar); Function getCoordinateByIndex():Integer;//取得坐标 begin Result:=SendMessage(FEditorHandle,EM_POSFROMCHAR,FirstPos+CharIndex,0); end; Var ArrayLen:Integer; KeyCoordinate:Integer; Color:TColor; begin if FHighLightSchema.Find(PChar(UpperCase(toWord)),Color) then//如果找到则返回颜色值 ,比较有问题 --- begin ArrayLen:=High(Result^)+1; inc(ArrayLen); SetLength(Result^,ArrayLen); KeyCoordinate:=getCoordinateByIndex; with Result^[ArrayLen-1] do begin WordToHightLigth:=toWord; WordCoordinate.X:=LOWORD(KeyCoordinate); WordCoordinate.Y:=HIWORD(KeyCoordinate); MaskColor:=Color; end; end; end; {$Endregion} begin Result:=nil; if StrLen(LineString)=0 then exit; Index:=0; FirstPos:=0; FWordBeing:=False; Searching:=False; New(Result);//释放用Dispose(Test); SetLength(Result^,0); while (LineString^<>#0) do //传入一个数组,这个数组里存放注释或被选中的部分的索引 begin // with FSelectionToAvoid do // begin // if iStart<>iEnd then // if ((CharIndex+Index)>=iStart) or ((CharIndex+Index)<iEnd) then // begin // inc(Index);inc(LineString);Continue; // end; // end; if Ord(LineString^) in [9,10,13,32..47,58..64,91..94,96,123..126] then //如果是分隔符 begin FWordBeing:=False; if FWord='' then begin inc(Index);inc(LineString);Continue; end; Processing(PChar(FWord)); //处理过程 FWord 这里的匹配分多种，注释，关键字，数值 etc. Searching:=false; FWord:=''; end else if Searching then //开始查找 if Ord(LineString^)>127 then begin FWord:=FWord+LineString^; inc(LineString); FWord:=FWord+LineString^; inc(Index); inc(LineString); Continue; end else FWord:=FWord+LineString^ else//注意下面的写法 ord()中不能是字符串，所以用 UpperCase()[1] if (ord(UpperCase(LineString^)[1]) in FHighLightSchema.IndexSort) and (not FWordBeing) then //如果在要高亮的字中没有这个首字开始的，Searching:=false; begin if Ord(LineString^)<=127 then //这里要判断是否为汉字 begin FirstChar:=LineString^; FWord:=LineString^; FirstPos:=Index; //取得首字的索引 Searching:=true; FWordBeing:=True; end; end else if Ord(LineString^)>127 then inc(LineString); inc(Index); inc(LineString); end; //if FWord<>'' then Result.Add(FWord); {$Endregion} end; end.

 

 

6、XmlMapper.pas

 unit XmlMapper; //用于加载配置信息 interface uses XMLIntf,XMLDoc,SysUtils,Classes,HighLightSchemaClass; Type TXmlMapper=Class Private FXmlName:String; Flanguages:TStrings; FSchema:THighLightSchema; //FLanguage: String; Procedure LoadSettings(FileName:PChar); Function CreateXmlDocument(Const FileName:String):IXmlDocument; Function GetSingleNode(XmlDoc:IXmlDocument;Const NodeLevel:Integer;Name:PChar):IXmlNode; procedure SetLanguage(const Value: String); Procedure LoadSchema(Language:PChar); Public Constructor Create(Const FileName:String); Destructor Destroy();Override; Property Language:String write SetLanguage; Property Languages:TStrings read Flanguages;//这是个集合 Property Schema:THighLightSchema Read FSchema; End; //加载文件，取得所有的语言 //根据语言取得要高亮的部分及颜色 implementation uses EventMessages; { TXmlMapper } {$Region ' 属性过程'} constructor TXmlMapper.Create(const FileName: String); begin FXmlName:=FileName; LoadSettings(PChar(FXmlName)); FSchema:=THighLightSchema.Create; end; function TXmlMapper.CreateXmlDocument(const FileName: String): IXmlDocument; begin Result:=NewXMLDocument; Result.LoadFromFile(FileName); end; destructor TXmlMapper.Destroy; begin FreeAndNil(Flanguages); FreeAndNil(FSchema); inherited; end; {$EndRegion} {$Region '根据结点级数取得子结点'} function TXmlMapper.GetSingleNode(XmlDoc: IXmlDocument;Const NodeLevel:Integer;Name:PChar): IXmlNode; //< xml version="1.0" encoding="utf-8" > level 0 //<Classify> level 1 // <Language Name="Delphi"> level 2 // <Item Name="注释"> level 3 // <Color>258369</Color> level 4 // <Words>AND,FOR,AS INC,NEXT</Words> level 4 // </Item> Var XmlNode:IXmlNode; I:Integer; begin Result:=nil; i:=1; if NodeLevel<1 then Raise Exception.Create(Format(XmlNodeNotFound,[Name])); XmlNode:=XmlDoc.DocumentElement;//根结点 while i<NodeLevel-1 do begin XmlNode:=XmlNode.ChildNodes.First; inc(i); end; for I := 0 to XmlNode.ChildNodes.Count - 1 do if XmlNode.ChildNodes[i].Attributes['Name']=Name then begin Result:=XmlNode.ChildNodes[i]; Break; end; end; {$EndRegion} {$Region' 根据语言取 Schema'} procedure TXmlMapper.LoadSchema(Language:PChar); Var XmlDoc:IXmlDocument; XmlNode:IXmlNode; I:Integer; begin XmlDoc:=CreateXmlDocument(FXmlName); XmlNode:=GetSingleNode(XmlDoc,2,PChar(Language)); FSchema.Clear; Try for I := 0 to XmlNode.ChildNodes.Count - 1 do with XmlNode.ChildNodes[i] do FSchema.AddItem(ChildNodes[1].Text,ChildNodes[0].Text); Except Raise Exception.Create(Format(XmlReadError,[FXmlName])); End; XmlDoc:=nil; end; {$EndRegion} {$Region ' 从文件读取所有语言'} procedure TXmlMapper.LoadSettings(FileName:PChar); Var XmlDoc:IXmlDocument; function GetLanguages(): TStrings; Var I:Integer; XmlNode:IXmlNode; begin XmlNode:=XmlDoc.DocumentElement; Result:=TStringList.Create; for I := 0 to XmlNode.ChildNodes.Count - 1 do Result.Add(XmlNode.ChildNodes[i].Attributes['Name']); end; begin XmlDoc:=CreateXmlDocument(FileName); Flanguages:=GetLanguages(); XmlDoc:=nil; end; procedure TXmlMapper.SetLanguage(const Value: String); begin LoadSchema(PChar(Value)); end; {$EndRegion} end.

 

 

7、主工程文件

unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, ToolWin,HighLightEditor, Menus, StdCtrls; type TForm1 = class(TForm) ToolBar1: TToolBar; ToolButton1: TToolButton; ComboBox1: TComboBox; ToolButton2: TToolButton; ToolButton3: TToolButton; Odld: TOpenDialog; ListBox1: TListBox; procedure FormShow(Sender: TObject); procedure ComboBox1Change(Sender: TObject); procedure ToolButton2Click(Sender: TObject); procedure ToolButton3Click(Sender: TObject); private var editor:THighLightEditor; public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.ComboBox1Change(Sender: TObject); begin editor.ProgramLanguage:=ComboBox1.Text; editor.SetFocus; end; procedure TForm1.FormShow(Sender: TObject); var margin:TMargins; begin editor:=THighLightEditor.Create(Self); margin:=TMargins.Create(editor); with margin do begin top:=3; Left:=3; Bottom:=3; right:=3; end; with editor do begin parent:=self; Align:=alClient; XmlFile:='Settings.xml'; Combobox1.Items.Assign(editor.Languages); editor.AlignWithMargins:=true; editor.Margins:=margin; end; FreeAndNil(margin); end; procedure TForm1.ToolButton2Click(Sender: TObject); begin editor.ShowSchemaEditor; end; procedure TForm1.ToolButton3Click(Sender: TObject); begin if odld.Execute(Handle) then editor.Lines.LoadFromFile(odld.FileName); editor.SetFocus; end; end.

 

8、代码较多，但绝对可行，我已经测试通过，有兴趣慢慢看吧。希望你有所收获