ShIvADeSt
Moderator | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код:
{****************************************************}
{ }
{ ColorEdit v1.0 }
{ }
{ Copyright (c) 2004 by Gon Perez-Jimenez }
{ http://www.torry.net/authorsmore.php?id=3649 }
{ }
{ Copyright (c) 2009 by ShIvADeSt Moderator Ru-Board }
{ }
{ Copyright (c) 2009 by Stalker SoftWare }
{ }
{****************************************************}
unit ColorEdit;
interface
uses
Windows, Messages, Classes, Graphics, StdCtrls, Controls;
type
TWordType = (wtSeparator, wtSpace, wtNumber, wtText);
TCheckWordEvent = procedure(Sender :TObject; cWord :String; WordType :TWordType; var FontColor, BackgroundColor :TColor; var IsUnderline :Boolean) of object;
TColorEdit = class(TEdit)
private
{ Private declarations }
FStartCaretPos :TSize;
FLineCaretPos :TSize;
FFocusLost :Boolean;
FSeparators :TStrings;
FOnCheckWord :TCheckWordEvent;
FKeepSelOnLostFocus :Boolean;
FAlignment :TAlignment;
FWordWrap :Boolean;
FWantReturns :Boolean;
procedure SetRedraw(Handle :THandle; Flag :Boolean);
procedure CharToCaret(nCharPos :Integer; var nRow, nColumn :Integer);
function TextFromLine(nRow:integer):string;
procedure WMKillFocus(var Message :TWMKillFocus); message WM_KILLFOCUS;
procedure WMSetFocus(var Message :TWMSetFocus); message WM_SETFOCUS;
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(oCanvas :TCanvas; cLineText :String; nCurLine :Integer; rTxtRect :TRect);
procedure DrawUnderline(oCanvas :TCanvas; nFromX, nFromY, nToX :Integer);
procedure SetSeparators(const Value :TStrings);
function NextWord(var cStr :String) :String;
function GetTextStart(nRow :Integer) :TSize;
procedure SetAlignment(const Value: TAlignment);
procedure SetWordWrap(const Value: Boolean);
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
protected
{ Protected declarations }
procedure CreateParams(var Params :TCreateParams); override;
public
{ Public declarations }
procedure GotoXY(nCol, nLine :Integer);
function Line() :Integer;
function Col() :Integer;
function TopLine() :Integer;
function VisibleLines() :Integer;
function IsSeparator(cStr :Char) :Boolean;
function IsNumber(cStr :String) :Boolean;
published
{ Published declarations }
constructor Create(AOwner :TComponent); override;
destructor Destroy(); override;
property Separators :TStrings read FSeparators write SetSeparators;
property OnCheckWord :TCheckWordEvent read FOnCheckWord write FOnCheckWord;
property KeepSelOnLostFocus :Boolean read FKeepSelOnLostFocus write FKeepSelOnLostFocus default False;
property WordWrap :Boolean read FWordWrap write SetWordWrap default False;
property WantReturns :Boolean read FWantReturns write FWantReturns default False;
property Alignment :TAlignment read FAlignment write SetAlignment default taLeftJustify;
end; { TColorEdit }
procedure Register;
implementation
constructor TColorEdit.Create(AOwner: TComponent);
begin
inherited;
FSeparators := TStringList.Create;
FSeparators.Add('.');
FSeparators.Add(',');
FSeparators.Add('|');
FSeparators.Add(' ');
FSeparators.Add(';');
FSeparators.Add(':');
FSeparators.Add('"');
FSeparators.Add('''');
FSeparators.Add('^');
FSeparators.Add('+');
FSeparators.Add('-');
FSeparators.Add('*');
FSeparators.Add('/');
FSeparators.Add('\');
FSeparators.Add('`');
FSeparators.Add('~');
FSeparators.Add('[');
FSeparators.Add(']');
FSeparators.Add('(');
FSeparators.Add(')');
FSeparators.Add('{');
FSeparators.Add('}');
FSeparators.Add('?');
FSeparators.Add('!');
FSeparators.Add('%');
FSeparators.Add('=');
FSeparators.Add('<');
FSeparators.Add('>');
FFocusLost := False;
FKeepSelOnLostFocus := False;
FAlignment := taLeftJustify;
FWordWrap := False;
FWantReturns := False;
end; { Create }
destructor TColorEdit.Destroy;
begin
FSeparators.Free;
inherited;
end; { Destroy }
function TColorEdit.TextFromLine(nRow:integer):string;
var
Text: array[0..4095] of Char;
L: Integer;
begin
Word((@Text)^) := SizeOf(Text);
L := SendMessage(Self.Handle, EM_GETLINE, nRow, Longint(@Text));
if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2);
SetString(Result, Text, L);
end;
procedure TColorEdit.SetSeparators(const Value :TStrings);
begin
FSeparators.Assign(Value);
end; { SetSeparators }
procedure TColorEdit.SetAlignment(const Value :TAlignment);
begin
if FAlignment <> Value then begin
FAlignment := Value;
RecreateWnd;
end; { if }
end; { SetAlignment }
procedure TColorEdit.SetWordWrap(const Value :Boolean);
begin
if Value <> FWordWrap then begin
FWordWrap := Value;
RecreateWnd;
end; { if }
end; { SetWordWrap }
procedure TColorEdit.WMGetDlgCode(var Message :TWMGetDlgCode);
begin
inherited;
if not FWantReturns then
Message.Result := (Message.Result and not DLGC_WANTALLKEYS);
end; { WMGetDlgCode }
procedure TColorEdit.CreateParams(var Params: TCreateParams);
const
Alignments: array[TAlignment] of Dword = (ES_LEFT, ES_RIGHT, ES_CENTER);
WordWraps: array[Boolean] of DWORD = (0, ES_AUTOHSCROLL);
begin
inherited CreateParams(Params);
if FWordWrap then
Params.Style := Params.Style and not WordWraps[FWordWrap] or ES_MULTILINE or
Alignments[FAlignment]
else
Params.Style := Params.Style or Alignments[FAlignment]
end; { CreateParams }
function TColorEdit.IsSeparator(cStr :Char) :Boolean;
begin
Result := (FSeparators.IndexOf(cStr) <> -1);
end; { IsSeparator }
function TColorEdit.NextWord(var cStr :String) :String;
begin
Result := '';
if cStr = '' then Exit;
if IsSeparator(cStr[1]) then begin
Result := Result+cStr[1];
Delete(cStr, 1, 1);
end else
while (cStr <> '') and (not IsSeparator(cStr[1])) do begin
Result := Result+cStr[1];
Delete(cStr, 1, 1);
end; { while }
end; { NextWord }
function TColorEdit.IsNumber(cStr :String) :Boolean;
var
i: Integer;
begin
Result := False;
for i:= 1 to Length(cStr) do
case cStr[i] of
'0'..'9':;
else
Exit;
end; { case }
Result := True;
end; { IsNumber }
function TColorEdit.VisibleLines() :Integer;
begin
Result := (Height div (Abs(Font.Height)+2));
end; { VisibleLines }
procedure TColorEdit.GotoXY(nCol, nLine :Integer);
begin
Dec(nLine);
SelStart := 0;
SelLength := 0;
SelStart := nCol+Perform(EM_LINEINDEX, nLine, 0);
SelLength :=0;
end; { GotoXY }
function TColorEdit.GetTextStart(nRow :Integer) :TSize;
var
ChrInd :Integer;
Res :LResult;
Caret : TPoint;
TxtRect:TRect;
begin
Result.cx := 0;
Result.cy := 0;
if Text = '' then Exit;
ChrInd := SendMessage(Handle, EM_LINEINDEX, nRow, 0);
Res := SendMessage(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-FStartCaretPos.cx;
Result.cy := HiWord(Res);
end; { if }
if NOT WordWrap then begin
Windows.GetCaretPos(Caret);
SendMessage(Handle,EM_GETRECT,0,LPARAM(@TxtRect));
Result.cy:= TxtRect.Top;
end;
end; { GetTextStart }
function TColorEdit.TopLine() :Integer;
begin
Result := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end; { TopLine }
function TColorEdit.Line() :Integer;
begin
Result := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
end; { Line }
function TColorEdit.Col() :Integer;
begin
Result := SelStart - SendMessage(Handle, EM_LINEINDEX, SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0), 0);
end; { Col }
procedure TColorEdit.SetRedraw(Handle :THandle; Flag :Boolean);
begin
SendMessage(Handle, WM_SETREDRAW, Ord(Flag), 0);
end; { SetRedraw }
procedure TColorEdit.WMVScroll(var Message :TWMVScroll);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end; { WMVScroll }
procedure TColorEdit.WMKillFocus(var Message :TWMKillFocus);
var
Locked :Boolean;
begin
Locked := False;
try
Locked := LockWindowUpdate(GetDesktopWindow());
FFocusLost:=True;
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
if Locked then LockWindowUpdate(0);
end; { try }
end; { WMKillFocus }
procedure TColorEdit.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; { try }
end; { WMSetFocus }
procedure TColorEdit.WMHScroll(var Message :TWMHScroll);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end; { WMHScroll }
procedure TColorEdit.WMSize(var Message :TWMSize);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end; { WMSize }
procedure TColorEdit.WMEraseBKGND(var Message :TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end; { WMEraseBKGND }
procedure TColorEdit.WMMove(var Message :TWMMove);
begin
Invalidate;
inherited;
end; { WMMove }
procedure TColorEdit.CharToCaret(nCharPos :Integer; var nRow, nColumn :Integer);
begin
nRow := SendMessage(Handle, EM_LINEFROMCHAR, nCharPos, 0)+1;
nColumn := nCharPos - SendMessage(Handle, EM_LINEINDEX, SendMessage(Handle, EM_LINEFROMCHAR, nCharPos, 0), 0);
end; { CharToCaret }
procedure TColorEdit.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; { try }
end; { WMLButtonUp }
procedure TColorEdit.WMLButtonDown(var Message :TWMLButtonDown);
var
Locked :Boolean;
begin
Locked := False;
if FFocusLost 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; { try }
end; { WMLButtonDown }
procedure TColorEdit.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; { try }
end; { WMLButtonDblClk }
procedure TColorEdit.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 FFocusLost then
Locked := LockWindowUpdate(Handle)
else
FFocusLost := False;
inherited;
finally
if (Locked) and (not FFocusLost) then LockWindowUpdate(0);
end; { try }
end; { if }
end; { WMMouseMove }
procedure TColorEdit.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; { try }
end; { WMMousewheel }
procedure TColorEdit.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; { try }
end; { WMCHAR }
procedure TColorEdit.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; { try }
end; { WMKeyDown }
procedure TColorEdit.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; { try }
end; { WMKeyUp }
procedure TColorEdit.PaintLine(oCanvas :TCanvas; cLineText :String; nCurLine :Integer; rTxtRect :TRect);
const
HilightFont = clHighlightText;
HilightBack = clHighlight;
type
TxtAttr = record
FontColor, BckColor :TColor;
Underline :Boolean;
end; { TxtAttr }
var
i, j, px :Integer;
nLineBeg, nColBeg, nLineEnd, nColEnd :Integer;
LastFont, LastBck :TColor;
LastUnderline :Boolean;
rSize :TSize;
t, cCurWord :String;
aCharsColor :array of TxtAttr;
evFontColor, evBckColor :TColor;
evUnderline :Boolean;
begin
try
CharToCaret(SelStart, nLineBeg, nColBeg);
CharToCaret(SelStart+SelLength, nLineEnd, nColEnd);
with oCanvas do begin
px := rTxtRect.Left;
t := cLineText+' ';
SetLength(aCharsColor, Length(cLineText)+1);
for i := 0 to High(aCharsColor) do begin // Инициализируем массив цветов символов
aCharsColor[i].FontColor := Self.Font.Color;
aCharsColor[i].BckColor := Self.Color;
aCharsColor[i].Underline := False;
end; { for }
i := 0;
repeat // Проходим по всей строке и задаем для каждого символа его цвет и цвет его фона
cCurWord := NextWord(t);
if cCurWord <> '' then begin
if cCurWord = ' ' then begin
evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
if Assigned(FOnCheckWord) then
FOnCheckWord(Self, cCurWord, wtSpace, evFontColor, evBckColor, evUnderline);
aCharsColor[i].FontColor := evFontColor;
aCharsColor[i].BckColor := evBckColor;
aCharsColor[i].Underline := evUnderline;
Inc(i);
end else
if IsSeparator(cCurWord[1]) then begin
evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
if Assigned(FOnCheckWord) then
FOnCheckWord(Self, cCurWord, wtSeparator, evFontColor, evBckColor, evUnderline);
aCharsColor[i].FontColor := evFontColor;
aCharsColor[i].BckColor := evBckColor;
aCharsColor[i].Underline := evUnderline;
Inc(i);
end else
if IsNumber(cCurWord) then begin
evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
if Assigned(FOnCheckWord) then
FOnCheckWord(Self, cCurWord, wtNumber, evFontColor, evBckColor, evUnderline);
for j := 1 to Length(cCurWord) do begin
aCharsColor[i+j-1].FontColor := evFontColor;
aCharsColor[i+j-1].BckColor := evBckColor;
aCharsColor[i+j-1].Underline := evUnderline;
end; { for }
Inc(i, Length(cCurWord));
end else begin // Задаем цвет остального текста
evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
if Assigned(FOnCheckWord) then
FOnCheckWord(Self, cCurWord, wtText, evFontColor, evBckColor, evUnderline);
for j:=1 to Length(cCurWord) do begin
aCharsColor[i+j-1].FontColor := evFontColor;
aCharsColor[i+j-1].BckColor := evBckColor;
aCharsColor[i+j-1].Underline := evUnderline;
end; { for }
Inc(i, Length(cCurWord));
end; { if }
end; { if }
until cCurWord = '';
if (Focused) or (FKeepSelOnLostFocus and not Focused) then begin // это если надо чтобы при потере фокуса исчезало выделение
if (nCurLine = nLineBeg) and (nColBeg <> nColEnd) and (nLineBeg = nLineEnd) then
for i := nColBeg+1 to nColEnd do begin
aCharsColor[i-1].FontColor := HilightFont;
aCharsColor[i-1].BckColor := HilightBack;
end; { for }
if (nCurLine > nLineBeg) and (nCurLine < nLineEnd) then
for i := 1 to Length(cLineText) do begin
aCharsColor[i-1].FontColor := HilightFont;
aCharsColor[i-1].BckColor := HilightBack;
end; { for }
if (nCurLine = nLineBeg) and (nLineBeg < nLineEnd) then
for i := nColBeg+1 to Length(cLineText) do begin
aCharsColor[i-1].FontColor := HilightFont;
aCharsColor[i-1].BckColor := HilightBack;
end; { for }
if (nCurLine = nLineEnd) and (nLineBeg < nLineEnd) then
for i := 1 to nColEnd do begin
aCharsColor[i-1].FontColor := HilightFont;
aCharsColor[i-1].BckColor := HilightBack;
end; { for }
end; { if }
cCurWord := cLineText[1];
LastFont := aCharsColor[0].FontColor;
LastBck := aCharsColor[0].BckColor;
LastUnderline := aCharsColor[0].Underline;
if Length(cLineText) = 1 then begin
rSize := TextExtent(cCurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck <> Self.Color then begin
Brush.Color := LastBck;
FillRect(Rect(px, rTxtRect.Top, px+rSize.cx, rTxtRect.Top+rSize.cy));
end; { if }
Font := Self.Font;
Font.Color := LastFont;
TextOut(px, rTxtRect.Top, cCurWord);
end; { if }
for i := 2 to Length(cLineText) do begin
t := cLineText[i];
if (LastFont <> aCharsColor[i-1].FontColor) or
(LastBck <> aCharsColor[i-1].BckColor) or
(LastUnderline <> aCharsColor[i-1].Underline) then begin
rSize := TextExtent(cCurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck <> Self.Color then begin
Brush.Color := LastBck;
FillRect(Rect(px, rTxtRect.Top, px+rSize.cx, rTxtRect.Top+rSize.cy))
end; { if }
Font := Self.Font;
Font.Color := LastFont;
TextOut(px, rTxtRect.Top, cCurWord);
if aCharsColor[i-2].Underline then
DrawUnderline(oCanvas, px, rTxtRect.Top+rSize.cy, px+rSize.cx);
Inc(px, rSize.cx);
cCurWord := '';
LastFont := aCharsColor[i-1].FontColor;
LastBck := aCharsColor[i-1].BckColor;
LastUnderline := aCharsColor[i-1].Underline;
end; { if }
cCurWord := cCurWord+cLineText[i];
if px > rTxtRect.Right then Break;
if i = Length(cLineText) then begin
rSize := TextExtent(cCurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck <> Self.Color then begin
Brush.Color := LastBck;
FillRect(Rect(px, rTxtRect.Top, px+rSize.cx, rTxtRect.Top+rSize.cy))
end; { if }
Font := Self.Font;
Font.Color := LastFont;
TextOut(px, rTxtRect.Top, cCurWord);
if aCharsColor[i-1].Underline then
DrawUnderline(oCanvas, px, rTxtRect.Top+rSize.cy, px+rSize.cx);
end; { if }
end; { for }
end; { with }
finally
SetLength(aCharsColor, 0);
end; { try }
end; { PaintLine }
procedure TColorEdit.WMPaint(var Message :TWMPaint);
var
PS :TPaintStruct;
psRect :TRect;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
oCanvas :TCanvas;
i :Integer;
rSize :TSize;
nMax :Integer;
nLineFirst :Integer;
nLineLast :Integer;
cLine :String;
begin
if (FStartCaretPos.cx = 0) and (Text <> '') and (Alignment = taLeftJustify) then
FStartCaretPos := 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);
oCanvas := TCanvas.Create;
try
oCanvas.Handle := DC;
oCanvas.Font := Self.Font;
with oCanvas do begin
if WordWrap then begin
nMax := TopLine()+VisibleLines();
if nMax > SendMessage(Handle, EM_GETLINECOUNT,0,0) then nMax := SendMessage(Handle, EM_GETLINECOUNT,0,0);
end
else
nMax := 0;
Brush.Color := Self.Color;
FillRect(Self.ClientRect);
rSize := TextExtent(' ');
if GetForegroundWindow() = Self.Parent.Handle then begin
nLineFirst := TopLine() + (PS.rcPaint.Top div rSize.cy);
nLineLast := TopLine() + (PS.rcPaint.Bottom div rSize.cy);
end else begin
nLineFirst := TopLine();
nLineLast := nMax;
end; { if }
for i := nLineFirst to nLineLast do begin
FLineCaretPos := GetTextStart(i);
cLine := TextFromLine(i); //Lines[i];
if cLine = '' then cLine :=' ';
rSize := TextExtent(cLine);
if FLineCaretPos.cy+rSize.cy <= psRect.Bottom then
PaintLine(oCanvas, cLine, i+1, Rect(FLineCaretPos.cx, FLineCaretPos.cy, Self.ClientRect.Right, FLineCaretPos.cy+rSize.cy));
end; { for }
end; { with }
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);
oCanvas.Free;
end; { try }
end; { WMPaint }
procedure TColorEdit.WMPrintClient(var Message :TWMPaint);
var
PS :TPaintStruct;
psRect :TRect;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
oCanvas :TCanvas;
i :Integer;
rSize :TSize;
nMax :Integer;
nLineFirst :Integer;
nLineLast :Integer;
cLine :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);
oCanvas := TCanvas.Create;
try
oCanvas.Handle := DC;
oCanvas.Font := Self.Font;
with oCanvas do begin
if WordWrap then begin
nMax := TopLine()+VisibleLines();
if nMax > SendMessage(Handle, EM_GETLINECOUNT,0,0) then nMax := SendMessage(Handle, EM_GETLINECOUNT,0,0);
end
else
nMax := 0;
Brush.Color := Self.Color;
FillRect(Self.ClientRect);
rSize := TextExtent(' ');
if GetForegroundWindow=Self.Parent.Handle then begin
nLineFirst := TopLine() + (PS.rcPaint.Top div rSize.cy);
nLineLast := TopLine() + (PS.rcPaint.Bottom div rSize.cy);
end else begin
nLineFirst := TopLine();
nLineLast := nMax;
end; { if }
for i := nLineFirst to nLineLast do begin
FLineCaretPos := GetTextStart(i);
cLine := TextFromLine(i); //Lines[i];
if cLine = '' then cLine := ' ';
rSize := TextExtent(cLine);
if FLineCaretPos.cy+rSize.cy <= psRect.Bottom then
PaintLine(oCanvas, cLine, i+1, Rect(FLineCaretPos.cx, FLineCaretPos.cy,Self.ClientRect.Right, FLineCaretPos.cy+rSize.cy));
end; { for }
end; { with }
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);
oCanvas.Free;
end; { try }
end; { WMPrintClient }
procedure TColorEdit.DrawUnderline(oCanvas :TCanvas; nFromX, nFromY, nToX: Integer);
var
X :Integer;
begin
with oCanvas do
for X := nFromX to nToX do
oCanvas.Pixels[X, nFromY+Round(Sin(X))] := clRed;
end; { DrawUnderline }
procedure Register;
begin
RegisterComponents('Samples', [TColorEdit]);
end; { Register }
end.
|
----------
И создал Бог женщину... Существо получилось злобное, но забавное... |
|
