ShIvADeSt
Moderator | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код:
(**
* 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;
type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
StartCaretPos :TSize;
function HScrollPos:integer;
procedure CharToCaret(CharPos:integer; var Row,Column:integer);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
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 WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMMousewheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
procedure PaintLine(Canvas:TCanvas; LineText:string;CurLine:integer; TxtRect:TRect);
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);
procedure Memo1Click(Sender: TObject);
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): String;
begin
result := '';
// PrevWord := '';
if s='' then Exit;
if IsSeparator(s[1]) then begin
result := result+s[1];
delete(s,1,1);
end else
{ 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);
{var
Locked : boolean;}
begin
// Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
// if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.HScrollPos:integer;
var
ScrollInfo : TScrollInfo;
begin
FillChar(ScrollInfo,SizeOf(TScrollInfo),0);
ScrollInfo.cbSize:=SizeOf(TScrollInfo);
ScrollInfo.fMask:=SIF_POS;
GetScrollInfo(Handle,SB_HORZ, ScrollInfo);
Result:=ScrollInfo.nPos;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMHScroll(var Message: TWMHScroll);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
var
Locked : boolean;
begin
Update_label;
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMEraseBKGND(var Message: TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.CharToCaret(CharPos:integer; var Row,Column:integer);
begin
Row := SendMessage(Self.Handle, EM_LINEFROMCHAR, CharPos, 0)+1;
Column := CharPos - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, CharPos, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonUp(var Message: TWMLButtonUp);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMouseMove(var Message: TWMMouseMove);
var
Locked :boolean;
begin
if (Message.Keys and MK_LBUTTON)=0 then inherited else begin
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMouseWheel);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMCHAR(var Message: TWMCHAR);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyUp(var Message: TWMKeyUp);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
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);
// invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.PaintLine(Canvas:TCanvas; LineText:string; CurLine:integer; TxtRect:TRect);
const
HilightFont = clNavy;
HilightBack = clSilver;
type
TxtAttr = record
FontColor, BckColor :TColor;
end;
var
i, j, x :integer;
LineSt,ColSt,LineEnd,ColEnd :integer;
LastFont, LastBck :TColor;
Size :TSize;
t, CurWord :string;
CharsColor :array of TxtAttr;
begin
try
CharToCaret(Self.SelStart,LineSt,ColSt);
CharToCaret(Self.SelStart+Self.SelLength,LineEnd,ColEnd);
with Canvas do begin
x:=TxtRect.Left;
t:=LineText+' ';
SetLength(CharsColor,Length(LineText)+1);
for i:=0 to High(CharsColor) do begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
end;
i:=0;
repeat
CurWord:=NextWord(t);
if CurWord<>'' then
if CurWord=' ' then begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsKeyWord(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clWhite;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else
if IsSeparator(CurWord[1]) then begin
CharsColor[i].FontColor:=clYellow;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsNumber(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clFuchsia;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clLime;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end;
until CurWord='';
if (CurLine=LineSt) and (ColSt<>ColEnd) and (LineSt=LineEnd) then
for i:=ColSt+1 to ColEnd do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine>LineSt) and (CurLine<LineEnd) then
for i:=1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine=LineSt) and (LineSt<LineEnd) then
for i:=ColSt+1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine=LineEnd) and (LineSt<LineEnd) then
for i:=1 to ColEnd do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
CurWord:=LineText[1];
LastFont:=CharsColor[0].FontColor;
LastBck:=CharsColor[0].BckColor;
if Length(LineText)=1 then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
for i:=2 to Length(LineText) do begin
t:=LineText[i];
if (LastFont<>CharsColor[i-1].FontColor) or (LastBck<>CharsColor[i-1].BckColor) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
Inc(x,Size.cx);
CurWord:='';
LastFont:=CharsColor[i-1].FontColor;
LastBck:=CharsColor[i-1].BckColor;
end;
CurWord:=CurWord+LineText[i];
if i=Length(LineText) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
end;
end;
finally
SetLength(CharsColor,0);
end;
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;
Size :TSize;
Max :Integer;
s : String;
Point :TPoint;
begin
{ inherited;
Exit;}
BeginPaint(Handle, PS);
if (StartCaretPos.cx=0) then begin
GotoXY(0,0);
Windows.GetCaretPos(Point);
StartCaretPos.cx:=Point.x;
StartCaretPos.cy:=Point.y;
end;
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
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);
Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
if Y+Size.cy<=psRect.Bottom then PaintLine(Canvas,s,i+1,Rect(x-HScrollPos,y,Size.cx,y+Size.cy));
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;
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;
Size :TSize;
Max :Integer;
s : 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
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);
Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
PaintLine(Canvas,s,i+1,Rect(x,y,Size.cx,y+Size.cy));
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;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
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;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1Click(Sender: TObject);
begin
if Memo1.SelLength=0 then Memo1.invalidate;
end;
end.
|
----------
И создал Бог женщину... Существо получилось злобное, но забавное... |
|
