delphi在TMemo中实现高亮文字
在memo中实现类似IDE的效果，对数字及自定义的关键字高亮显示，并自定义关键字
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;type TMemo = class(stdctrls.TMemo) private procedure WMPaint(var Message: TWMPaint); message WM_PAINT; procedure WMSize(var Message: TWMSize); message WM_SIZE; procedure WMMove(var Message: TWMMove); message WM_MOVE; procedure WMVScroll(var Message: TWMMove); message WM_VSCROLL; procedure WMMousewheel(var Message: TWMMove); message WM_MOUSEWHEEL; protected procedure Change; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyUp(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; public PosLabel: TLabel; procedure Update_label; procedure GotoXY(mCol, mLine: Integer); function Line: Integer; function Col: Integer; function TopLine: Integer; function VisibleLines: Integer; end;type TForm1 = class(TForm) Label1: TLabel; GroupBox1: TGroupBox; KeywordList: TListBox; GroupBox2: TGroupBox; GroupBox3: TGroupBox; Memo1: TMemo; Label2: TLabel; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm}//分隔符，如有特殊需要自己添加function IsSeparator(Car: Char): Boolean;begin case Car of '.', ';', ',', ':', '?', '!', '"', '''',' ', '^', '+', '-', '*', '/', '\', '`', '[', ']', '(', ')', 'o', 'a', '{', '}', '%', '=': Result := True; else Result := False; end;end;//////////////////////////////////////////////////////////////////////////////// function NextWord(var s: string; var PrevWord: string): string;begin Result := ''; PrevWord := ''; if s = '' then Exit; while (s <> '') and IsSeparator(s[1]) do begin PrevWord := PrevWord + s[1]; Delete(s, 1, 1); end; while (s <> '') and not IsSeparator(s[1]) do begin Result := Result + s[1]; Delete(s, 1, 1); end;end;//////////////////////////////////////////////////////////////////////////////// function IsKeyWord(s: string): Boolean;begin Result := False; if s = '' then Exit; Result := Form1.KeywordList.Items.IndexOf(lowercase(s)) <> -1;end;//////////////////////////////////////////////////////////////////////////////// function IsNumber(s: string): Boolean;var i: Integer;begin Result := False; for i := 1 to Length(s) do case s[i] of '0'..'9': ; else Exit; end; Result := True;end;////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// New or overrided methods and properties for TMemo using Interjected Class ///// Technique /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TMemo.VisibleLines: Integer;begin Result := Height div (Abs(Self.Font.Height) + 2);end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.GotoXY(mCol, mLine: Integer);begin Dec(mLine); SelStart := 0; SelLength := 0; SelStart := mCol + Self.Perform(EM_LINEINDEX, mLine, 0); SelLength := 0; SetFocus;end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.Update_label;begin if PosLabel = nil then Exit; PosLabel.Caption := '(' + IntToStr(Line + 1) + ',' + IntToStr(Col) + ')';end;//////////////////////////////////////////////////////////////////////////////// function TMemo.TopLine: Integer;begin Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);end;//////////////////////////////////////////////////////////////////////////////// function TMemo.Line: Integer;begin Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);end;//////////////////////////////////////////////////////////////////////////////// function TMemo.Col: Integer;begin Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0), 0);end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.WMVScroll(var Message: TWMMove);begin Update_label; Invalidate; inherited;end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.WMSize(var Message: TWMSize);begin Invalidate; inherited;end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.WMMove(var Message: TWMMove);begin Invalidate; inherited;end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.WMMousewheel(var Message: TWMMove);begin Invalidate; inherited;end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.Change;begin Update_label; Invalidate; inherited Change;end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);begin Update_label; inherited KeyDown(Key, Shift);end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);begin Update_label; inherited KeyUp(Key, Shift);end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);begin Update_label; inherited MouseDown(Button, Shift, X, Y);end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);begin Update_label; inherited MouseUp(Button, Shift, X, Y);end;//////////////////////////////////////////////////////////////////////////////// procedure TMemo.WMPaint(var Message: TWMPaint);var PS: TPaintStruct; DC: HDC; Canvas: TCanvas; i: Integer; X, Y: Integer; OldColor: TColor; Size: TSize; Max: Integer; s, Palabra, PrevWord: string;begin DC := Message.DC; if DC = 0 then DC := BeginPaint(Handle, PS); Canvas := TCanvas.Create; try OldColor := Font.Color; Canvas.Handle := DC; Canvas.Font.Name := Font.Name; Canvas.Font.Size := Font.Size; with Canvas do begin Max := TopLine + VisibleLines; if Max > Pred(Lines.Count) then Max := Pred(Lines.Count); //Limpio la sección visible Brush.Color := Self.Color; FillRect(Self.ClientRect); Y := 1; for i := TopLine to Max do begin X := 2; s := Lines[i]; //Detecto todas las palabras de esta línea Palabra := NextWord(s, PrevWord); while Palabra <> '' do begin Font.Color := OldColor; TextOut(X, Y, PrevWord); GetTextExtentPoint32(DC, PChar(PrevWord), Length(PrevWord), Size); Inc(X, Size.cx); Font.Color := clBlack; if IsKeyWord(Palabra) then begin Font.Color := clHighlight; TextOut(X, Y, Palabra); { //Draw dot underline Pen.Color := clHighlight; Pen.Style := psDot; PolyLine([ Point(X,Y+13), Point(X+TextWidth(Palabra),Y+13)]); } end else if IsNumber(Palabra) then begin Font.Color := $000000DD; TextOut(X, Y, Palabra); end else begin TextOut(X, Y, Palabra); end; GetTextExtentPoint32(DC, PChar(Palabra), Length(Palabra), Size); Inc(X, Size.cx); Palabra := NextWord(s, PrevWord); if (s = '') and (PrevWord <> '') then begin Font.Color := OldColor; TextOut(X, Y, PrevWord); end; end; if (s = '') and (PrevWord <> '') then begin Font.Color := OldColor; TextOut(X, Y, PrevWord); end; s := 'W'; GetTextExtentPoint32(DC, PChar(s), Length(s), Size); Inc(Y, Size.cy); end; end; finally if Message.DC = 0 then EndPaint(Handle, PS); end; Canvas.Free; inherited;end; procedure TForm1.FormCreate(Sender: TObject);begin Memo1.PosLabel := Label1; Memo1.Update_label;end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);begin Action := caFree;end; end.
关键字词:
