Delphi: Создание простого цветного TMemo или TEdit - [89] :: Прикладное программирование

Код:

(**
* 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
LineCaretPos,
StartCaretPos :TSize;
FocusLost :boolean;
function HScrollPos:integer;
procedure CharToCaret(CharPos:integer; var Row,Column:integer);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
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);
function IsKeyWord (S: String ):Boolean;
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;
HighlightWords : TStrings;
procedure Update_label;
procedure AddHighlightWords(Words:string; Separator:char);
function GetTextStart(Row:integer):TSize;
function Line : Integer;
function Col : Integer;
function TopLine : Integer;
function VisibleLines: Integer;
constructor Create(AOwner: TComponent); override;
end;

TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
Label6: TLabel;
Button1: TButton;
Memo2: TMemo;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Memo1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.DFM}

procedure SetRedraw(Handle:THandle; Flag: boolean);
begin
SendMessage(Handle,WM_SETREDRAW, Ord(Flag), 0);
end;

////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Symbol:char):Boolean;
begin
Case Symbol of
'.', ';', ',', ':', 'Ў', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', 'Ё',' ',
'`', '[', ']', '(', ')', 'є', 'Є', '{', '}', '?', 'ї', '%','=', '<','>': result := true;
else
result := false;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function NextWord ( var s: String): String;
begin
result := '';
if s='' then Exit;
if IsSeparator(s[1]) then begin
result := result+s[1];
delete(s,1,1);
end else
while(s<>'') and not IsSeparator(s[1]) do begin
result := result+s[1];
delete(s,1,1);
end;
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.IsKeyWord ( s: String ):Boolean;
begin
result := False;
if s='' then Exit;
result := HighlightWords.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;
////////////////////////////////////////////////////////////////////////////////
function TMemo.GetTextStart(Row:integer):TSize;
var
ChrInd : integer;
Res : LResult;
begin
Result.cx := 0;
Result.cy := 0;
if Self.Lines.Count <= 0 then Exit;
case Self.ScrollBars of
ssBoth, ssHorizontal:
if HScrollPos=0 then begin
ChrInd:=SendMessage(Handle, EM_LINEINDEX, Row, 0);
Res := SendMessage(Self.Handle,EM_POSFROMCHAR, ChrInd,0);
if Res>0 then begin
Result.cx:=LoWord(Res);
Result.cy:=HiWord(Res);
end
end
else begin
ChrInd:=SendMessage(Handle, EM_LINEINDEX, Row, 0);
Res := SendMessage(Self.Handle,EM_POSFROMCHAR, ChrInd,0);
if Res>0 then begin
Result.cx:=StartCaretPos.cx-HScrollPos;
Result.cy:=HiWord(Res);
end;
end;
ssVertical, ssNone:
begin
ChrInd:=SendMessage(Handle, EM_LINEINDEX, Row, 0);
Res := SendMessage(Self.Handle,EM_POSFROMCHAR, ChrInd,0);
if Res>0 then begin
Result.cx:=LoWord(Res);
if Result.cx>Self.ClientRect.Right then Result.cx:=Result.cx-65535;
Result.cy:=HiWord(Res);
end
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.AddHighlightWords(Words:string;Separator:char);
var
CurWord :string;
begin
While Words[1]=Separator do Delete(Words,1,1);
While Words[Length(Words)]=Separator do Delete(Words,Length(Words),1);
if (Words[Length(Words)]<>Separator) and (Length(Words)>0) then Words:=Words+Separator;
repeat
CurWord:=Copy(Words,1,Pos(Separator,Words)-1);
HighlightWords.Add(CurWord);
Delete(Words,1,Pos(Separator,Words));
until Words='';
end;
////////////////////////////////////////////////////////////////////////////////
constructor TMemo.Create(AOwner: TComponent);
begin
HighlightWords:=TStringList.Create;
HighlightWords.Clear;
AddHighlightWords('and#array#as#asm#begin#case#class#const#constructor#destructor#dispinterface'+
'#div#do#downto#else#end#except#exports#file#finalization#finally#for#function#'+
'goto#if#implementation#in#inherited#initialization#inline#interface#is#label#'+
'library#mod#nil#not#object#of#or#out#overload#override#packed#private#procedure'+
'#program#property#protected#public#raise#record#reintroduce#repeat#resourcestring'+
'#set#shl#shr#string#then#threadvar#to#try#type#unit#until#uses#var#while#with#xor','#');
inherited;
FocusLost:=False;
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);
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:=False;
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure Tmemo.WMKillFocus(var Message: TWMKillFocus);
begin
try
SetRedraw(Handle,False);
FocusLost:=True;
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
SetRedraw(Handle,True);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure Tmemo.WMSetFocus(var Message: TWMSetFocus);
var
Locked:boolean;
begin
Locked:=False;
try
Locked:=LockWindowUpdate(GetDesktopWindow);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Locked : boolean;
begin
Locked:=False;
if FocusLost then begin
SetRedraw(Handle,False);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
SetRedraw(Handle,True);
end
else
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
var
Locked : boolean;
begin
Locked:=False;
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMouseMove(var Message: TWMMouseMove);
var
Locked : boolean;
begin
Locked:=False;
if (Message.Keys and MK_LBUTTON)=0 then inherited else begin
try
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if NOT FocusLost then
Locked:=LockWindowUpdate(Handle)
else
FocusLost:=False;
inherited;
finally
if Locked and NOT FocusLost then LockWindowUpdate(0);
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMouseWheel);
var
Locked : boolean;
begin
Locked:=False;
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMCHAR(var Message: TWMCHAR);
var
Locked : boolean;
begin
Locked:=False;
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
var
Locked : boolean;
begin
Locked:=False;
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyUp(var Message: TWMKeyUp);
var
Locked : boolean;
begin
Locked:=False;
try
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end;
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, px :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
px:=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 Focused or NOT HideSelection then begin // это если надо чтобы при потере фокуса исчезало выделение
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;
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(px,TxtRect.Top,px+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(px,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(px,TxtRect.Top,px+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(px,TxtRect.Top, CurWord);
Inc(px,Size.cx);
CurWord:='';
LastFont:=CharsColor[i-1].FontColor;
LastBck:=CharsColor[i-1].BckColor;
end;
CurWord:=CurWord+LineText[i];
if px>TxtRect.Right then Break;
if i=Length(LineText) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(px,TxtRect.Top,px+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(px,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;
psRect :TRect;
Size :TSize;
Max, LineFirst,
LineLast :Integer;
s : String;
begin
{ inherited;
Exit;}
if (StartCaretPos.cx=0) and (Self.Lines.Count>0) and (Self.Alignment=taLeftJustify) then
StartCaretPos:=GetTextStart(0);
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 );
Size:=TextExtent(' ');
if GetForegroundWindow=Self.Parent.Handle then begin
LineFirst:= TopLine+(PS.rcPaint.Top div Size.cy);
LineLast:=TopLine+(PS.rcPaint.Bottom div Size.cy);
end
else begin
LineFirst:= TopLine;
LineLast:=Max;
end;
for i:=LineFirst to LineLast do begin
LineCaretPos:=GetTextStart(i);
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
if LineCaretPos.cy+Size.cy<=psRect.Bottom then PaintLine(Canvas,s,i+1,Rect(LineCaretPos.cx,LineCaretPos.cy,Self.ClientRect.Right,LineCaretPos.cy+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;
psRect :TRect;
Size :TSize;
Max, LineFirst,
LineLast :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 );
Size:=TextExtent(' ');
if GetForegroundWindow=Self.Parent.Handle then begin
LineFirst:= TopLine+(PS.rcPaint.Top div Size.cy);
LineLast:=TopLine+(PS.rcPaint.Bottom div Size.cy);
end
else begin
LineFirst:= TopLine;
LineLast:=Max;
end;
for i:=LineFirst to LineLast do begin
LineCaretPos:=GetTextStart(i);
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
if LineCaretPos.cy+Size.cy<=psRect.Bottom then PaintLine(Canvas,s,i+1,Rect(LineCaretPos.cx,LineCaretPos.cy,Self.ClientRect.Right,LineCaretPos.cy+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);
var
Point : TPoint;
begin
if Key=VK_F1 then Memo1.Invalidate;
if Key=VK_F2 then begin
Windows.GetCaretPos(Point);
ShowMessage(Format('%d:%d',[Point.x,Point.y]));
end;
if Key=VK_F3 then Windows.SetCaretPos(20,2);
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;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Memo1.Alignment=taCenter then begin
Memo1.Alignment:=taRightJustify;
Exit;
end;
if Memo1.Alignment=taRightJustify then begin
Memo1.LineCaretPos.cx:=0;
Memo1.Alignment:=taLeftJustify;
Exit;
end;
if Memo1.Alignment=taLeftJustify then begin
Memo1.Alignment:=taCenter;
Exit;
end;

end;

end.

----------
И создал Бог женщину... Существо получилось злобное, но забавное...

Модерирует : ShIvADeSt
Версия для печати • Подписаться • Добавить в закладки
На первую страницу • к этому сообщению • к последнему сообщению