代码即时高亮源码,delphi实现

1、配置文件

 

< ? x m l 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