В общем представляю на суд публики Мемо с подавленным мерцанием (полдня копал, чтобы убить мерцание при разных событиях). Код рабочий (по крайней мере на моей машине), багов не нашел (надеюсь
).
[more]
Код: (**
* Highlight with TMemo Impossible? try this...
* by Gon Perez-Jimenez May'04
*
* This is a sample how to work with highlighting within TMemo component by
* using interjected class technique.
*
* Of course, this code is still uncompleted but it works fine for my
* purposes, so, hope you can improve it and use it.
*
*)
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMCHAR(var Message: TWMCHAR); message WM_CHAR;
procedure WMPrintClient(var Message: TWMPaint); message WM_PRINTCLIENT;
procedure WMERASEBKGND(var Message: TWMERASEBKGND); message WM_ERASEBKGND;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure WMVScroll(var Message: TWMVScroll); 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;
TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
KeywordList: TListBox;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car:char):Boolean;
begin
Case Car of
'.', ';', ',', ':', 'Ў', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', 'Ё',' ',
'`', '[', ']', '(', ')', 'є', 'Є', '{', '}', '?', 'ї', '%','=': 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: TWMVScroll);
begin
Update_label;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMEraseBKGND(var Message: TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMove);
begin
SendMessage(Handle, WM_SETREDRAW, Integer(FALSE), 0);
inherited;
SendMessage(Handle, WM_SETREDRAW, Integer(TRUE), 0);
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMCHAR(var Message: TWMCHAR);
begin
LockWindowUpdate(Handle);
inherited;
LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
begin
LockWindowUpdate(Handle);
inherited;
LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyDown(Key,Shift);
LockWindowUpdate(Handle);
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
LockWindowUpdate(0);
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;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
OldColor :TColor;
Size :TSize;
Max :Integer;
s, Palabra,
PrevWord : String;
begin
BeginPaint(Handle, PS);
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
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:=0;
for i:=TopLine to Max do begin
x:=psRect.Left;
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);
end else
if IsNumber(Palabra) then begin
Font.Color:=$000000DD;
TextOut(X,Y, Palabra);
end else
TextOut(X,Y, Palabra);
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;
if s='' then s:='W';
GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
// inherited;
end;
procedure TMemo.WMPrintClient(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
OldColor :TColor;
Size :TSize;
Max :Integer;
s, Palabra,
PrevWord : String;
begin
BeginPaint(Handle, PS);
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
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:=0;
for i:=TopLine to Max do begin
x:=psRect.Left;
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);
end else
if IsNumber(Palabra) then begin
Font.Color:=$000000DD;
TextOut(X,Y, Palabra);
end else
TextOut(X,Y, Palabra);
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;
if s='' then s:='W';
GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
// inherited;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
// Memo1.DoubleBuffered:=True;
Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////
end.
