RSS订阅 | 匿名投稿
您的位置:网站首页 > 控件 > 正文

delphi在TMemo中实现高亮文字

作者:admin 来源:未知 日期:2010/4/26 22:34:36 人气: 标签:

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 }  endvar  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;endprocedure TForm1.FormCreate(Sender: TObject);begin  Memo1.PosLabel := Label1;  Memo1.Update_label;endprocedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);begin  Action := caFree;endend.

读完这篇文章后,您心情如何?
0
0
0
0
0
0
0
0
本文网址: