迷你5207专属论坛

注册

 

返回列表
发新话题 回复该主题
查看: 1242|回复: 0

TMemo高亮显示文字 [复制链接]

mini188
头像

mini188

  • 封僵大吏
  • 148
  • 314
  • 156
  • 520.2 M
元老奖章人才奖章劳动奖章烈日奖章老马奖章荣誉奖章
发表者
t T
发表于 2011-01-22 21:45 |只看楼主
delphi在TMemo中实现高亮文字
在memo中实现类似IDE的效果，对数字及自定义的关键字高亮显示，并自定义关键字
  1. unit Unit1;

  3. interface

  5. uses
  6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7.   Dialogs, StdCtrls;
  8. type
  9.   TMemo = class(stdctrls.TMemo)
  10.   private
  11.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  12.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  13.     procedure WMMove(var Message: TWMMove); message WM_MOVE;
  14.     procedure WMVScroll(var Message: TWMMove); message WM_VSCROLL;
  15.     procedure WMMousewheel(var Message: TWMMove); message WM_MOUSEWHEEL;
  16.   protected
  17.     procedure Change; override;
  18.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  19.     procedure KeyUp(var Key: Word; Shift: TShiftState); override;
  20.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  21.       override;
  22.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  23.       override;
  24.   public
  25.     PosLabel: TLabel;
  26.     procedure Update_label;
  27.     procedure GotoXY(mCol, mLine: Integer);
  28.     function Line: Integer;
  29.     function Col: Integer;
  30.     function TopLine: Integer;
  31.     function VisibleLines: Integer;
  32.   end;
  33. type
  34.   TForm1 = class(TForm)
  35.     Label1: TLabel;
  36.     GroupBox1: TGroupBox;
  37.     KeywordList: TListBox;
  38.     GroupBox2: TGroupBox;
  39.     GroupBox3: TGroupBox;
  40.     Memo1: TMemo;
  41.     Label2: TLabel;
  42.     procedure FormCreate(Sender: TObject);
  43.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  44.   private
  45.     { Private declarations }
  46.   public
  47.     { Public declarations }
  48.   end;

  50. var
  51.   Form1: TForm1;

  53. implementation

  55. {$R *.dfm}
  56. //分隔符，如有特殊需要自己添加
  57. function IsSeparator(Car: Char): Boolean;
  58. begin
  59.   case Car of
  60.     '.', ';', ',', ':', '?', '!', '"', '''',' ', '^', '+', '-', '*', '/', '\', '`', '[', ']', '(', ')', 'o', 'a', '{', '}', '%', '=': Result := True;
  61.   else
  62.     Result := False;
  63.   end;
  64. end;
  65. ////////////////////////////////////////////////////////////////////////////////

  67. function NextWord(var s: string; var PrevWord: string): string;
  68. begin
  69.   Result := '';
  70.   PrevWord := '';
  71.   if s = '' then Exit;
  72.   while (s <> '') and IsSeparator(s[1]) do
  73.   begin
  74.     PrevWord := PrevWord + s[1];
  75.     Delete(s, 1, 1);
  76.   end;
  77.   while (s <> '') and not IsSeparator(s[1]) do
  78.   begin
  79.     Result := Result + s[1];
  80.     Delete(s, 1, 1);
  81.   end;
  82. end;
  83. ////////////////////////////////////////////////////////////////////////////////

  85. function IsKeyWord(s: string): Boolean;
  86. begin
  87.   Result := False;
  88.   if s = '' then Exit;
  89.   Result := Form1.KeywordList.Items.IndexOf(lowercase(s)) <> -1;
  90. end;
  91. ////////////////////////////////////////////////////////////////////////////////

  93. function IsNumber(s: string): Boolean;
  94. var
  95.   i: Integer;
  96. begin
  97.   Result := False;
  98.   for i := 1 to Length(s) do
  99.     case s[i] of
  100.       '0'..'9': ;
  101.     else
  102.       Exit;
  103.     end;
  104.   Result := True;
  105. end;
  106. ////////////////////////////////////////////////////////////////////////////////
  107. ////////////////////////////////////////////////////////////////////////////////
  108. ////////////////////////////////////////////////////////////////////////////////
  109. // New or overrided methods and properties for TMemo using Interjected Class ///
  110. // Technique ///////////////////////////////////////////////////////////////////
  111. ////////////////////////////////////////////////////////////////////////////////

  113. function TMemo.VisibleLines: Integer;
  114. begin
  115.   Result := Height div (Abs(Self.Font.Height) + 2);
  116. end;
  117. ////////////////////////////////////////////////////////////////////////////////

  119. procedure TMemo.GotoXY(mCol, mLine: Integer);
  120. begin
  121.   Dec(mLine);
  122.   SelStart := 0;
  123.   SelLength := 0;
  124.   SelStart := mCol + Self.Perform(EM_LINEINDEX, mLine, 0);
  125.   SelLength := 0;
  126.   SetFocus;
  127. end;
  128. ////////////////////////////////////////////////////////////////////////////////

  130. procedure TMemo.Update_label;
  131. begin
  132.   if PosLabel = nil then Exit;
  133.   PosLabel.Caption := '(' + IntToStr(Line + 1) + ',' + IntToStr(Col) + ')';
  134. end;
  135. ////////////////////////////////////////////////////////////////////////////////

  137. function TMemo.TopLine: Integer;
  138. begin
  139.   Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
  140. end;
  141. ////////////////////////////////////////////////////////////////////////////////

  143. function TMemo.Line: Integer;
  144. begin
  145.   Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
  146. end;
  147. ////////////////////////////////////////////////////////////////////////////////

  149. function TMemo.Col: Integer;
  150. begin
  151.   Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX,
  152.     SendMessage(Self.Handle,
  153.     EM_LINEFROMCHAR, Self.SelStart, 0), 0);
  154. end;
  155. ////////////////////////////////////////////////////////////////////////////////

  157. procedure TMemo.WMVScroll(var Message: TWMMove);
  158. begin
  159.   Update_label;
  160.   Invalidate;
  161.   inherited;
  162. end;
  163. ////////////////////////////////////////////////////////////////////////////////

  165. procedure TMemo.WMSize(var Message: TWMSize);
  166. begin
  167.   Invalidate;
  168.   inherited;
  169. end;
  170. ////////////////////////////////////////////////////////////////////////////////

  172. procedure TMemo.WMMove(var Message: TWMMove);
  173. begin
  174.   Invalidate;
  175.   inherited;
  176. end;
  177. ////////////////////////////////////////////////////////////////////////////////

  179. procedure TMemo.WMMousewheel(var Message: TWMMove);
  180. begin
  181.   Invalidate;
  182.   inherited;
  183. end;
  184. ////////////////////////////////////////////////////////////////////////////////

  186. procedure TMemo.Change;
  187. begin
  188.   Update_label;
  189.   Invalidate;
  190.   inherited Change;
  191. end;
  192. ////////////////////////////////////////////////////////////////////////////////

  194. procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
  195. begin
  196.   Update_label;
  197.   inherited KeyDown(Key, Shift);
  198. end;
  199. ////////////////////////////////////////////////////////////////////////////////

  201. procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
  202. begin
  203.   Update_label;
  204.   inherited KeyUp(Key, Shift);
  205. end;
  206. ////////////////////////////////////////////////////////////////////////////////

  208. procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  209. begin
  210.   Update_label;
  211.   inherited MouseDown(Button, Shift, X, Y);
  212. end;
  213. ////////////////////////////////////////////////////////////////////////////////

  215. procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  216. begin
  217.   Update_label;
  218.   inherited MouseUp(Button, Shift, X, Y);
  219. end;
  220. ////////////////////////////////////////////////////////////////////////////////

  222. procedure TMemo.WMPaint(var Message: TWMPaint);
  223. var
  224.   PS: TPaintStruct;
  225.   DC: HDC;
  226.   Canvas: TCanvas;
  227.   i: Integer;
  228.   X, Y: Integer;
  229.   OldColor: TColor;
  230.   Size: TSize;
  231.   Max: Integer;
  232.   s, Palabra, PrevWord: string;
  233. begin
  234.   DC := Message.DC;
  235.   if DC = 0 then DC := BeginPaint(Handle, PS);
  236.   Canvas := TCanvas.Create;
  237.   try
  238.     OldColor := Font.Color;
  239.     Canvas.Handle := DC;
  240.     Canvas.Font.Name := Font.Name;
  241.     Canvas.Font.Size := Font.Size;
  242.     with Canvas do
  243.     begin
  244.       Max := TopLine + VisibleLines;
  245.       if Max > Pred(Lines.Count) then Max := Pred(Lines.Count);

  247.       //Limpio la sección visible
  248.       Brush.Color := Self.Color;
  249.       FillRect(Self.ClientRect);
  250.       Y := 1;
  251.       for i := TopLine to Max do
  252.       begin
  253.         X := 2;
  254.         s := Lines[i];

  256.         //Detecto todas las palabras de esta línea
  257.         Palabra := NextWord(s, PrevWord);
  258.         while Palabra <> '' do
  259.         begin
  260.           Font.Color := OldColor;
  261.           TextOut(X, Y, PrevWord);
  262.           GetTextExtentPoint32(DC, PChar(PrevWord), Length(PrevWord), Size);
  263.           Inc(X, Size.cx);

  265.           Font.Color := clBlack;
  266.           if IsKeyWord(Palabra) then
  267.           begin
  268.             Font.Color := clHighlight;

  270.             TextOut(X, Y, Palabra);
  271.              {
  272.              //Draw dot underline
  273.              Pen.Color := clHighlight;
  274.              Pen.Style := psDot;
  275.              PolyLine([ Point(X,Y+13), Point(X+TextWidth(Palabra),Y+13)]);
  276.              }
  277.           end
  278.           else if IsNumber(Palabra) then
  279.           begin
  280.             Font.Color := $000000DD;
  281.             TextOut(X, Y, Palabra);
  282.           end
  283.           else
  284.           begin

  286.             TextOut(X, Y, Palabra);
  287.            end;
  288.           GetTextExtentPoint32(DC, PChar(Palabra), Length(Palabra), Size);
  289.           Inc(X, Size.cx);

  291.           Palabra := NextWord(s, PrevWord);
  292.           if (s = '') and (PrevWord <> '') then
  293.           begin
  294.             Font.Color := OldColor;
  295.             TextOut(X, Y, PrevWord);
  296.           end;
  297.         end;
  298.         if (s = '') and (PrevWord <> '') then
  299.         begin
  300.           Font.Color := OldColor;
  301.           TextOut(X, Y, PrevWord);
  302.         end;

  304.         s := 'W';
  305.         GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
  306.         Inc(Y, Size.cy);
  307.       end;
  308.     end;
  309.   finally
  310.     if Message.DC = 0 then EndPaint(Handle, PS);
  311.   end;
  312.   Canvas.Free;
  313.   inherited;
  314. end;

  316. procedure TForm1.FormCreate(Sender: TObject);
  317. begin
  318.   Memo1.PosLabel := Label1;
  319.   Memo1.Update_label;
  320. end;

  322. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  323. begin
  324.   Action := caFree;
  325. end;

  327. end.
复制代码
分享 转发
TOP
上一主题| 下一主题
返回列表
发新话题 回复该主题
高级编辑器高级编辑器