StalkerSoftware Цитата: При выделении мышкой или просто тыканье мышкой в сингллайн едите очень заметно мерцание текста в едите. А при наборе текста видно некоторое замедление отображения курсора текста. Хотя само выделение теперь стало правильным.
Мерцание происходит потому что пришлось для сингллайна отказаться от двойной буферизации (в родном едите тоже мерцает, можешь проверить). Замедление отображения - попробую побороть, просто знаю почему это происходит, а вот как это исправить пока нет. Если не удастся - то это окончательный вариант, просто сингллайн едит очень странный контрол, он упорно пытается отрисовать себя сам, даже когда это не надо (если ты заметил, то для подавления самостоятельной отрисовки пришлось принудительно выходить из обработчика WM_PAINT, что можно (видел случаи), но не красиво).
Добавлено Забейте на написаное выше, вроде бы (в очередной раз БЫ) победил глюки для single-line edit
[more]
Код: {****************************************************}
{ }
{ 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, SysUtils;
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;
Start :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
EditText: array[0..4095] of Char;
L: Integer;
begin
Word((@EditText)^) := SizeOf(EditText);
L := SendMessage(Self.Handle, EM_GETLINE, nRow, Longint(@EditText));
if (EditText[L - 2] = #13) and (EditText[L - 1] = #10) then Dec(L, 2);
SetString(Result, EditText, 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;
TxtOffset :TRect;
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 := '';
LastBck := aCharsColor[i-1].BckColor;
LastFont := aCharsColor[i-1].FontColor;
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;
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 }
SendMessage(Self.Handle,EM_GETRECT,0,LPARAM(@TxtOffset));
Brush.Color := Self.Color;
FillRect(Rect(0, rTxtRect.Top, TxtOffset.Left, rTxtRect.Top+rSize.cy))
end; { with }
finally
SetLength(aCharsColor, 0);
end; { try }
end; { PaintLine }
procedure TColorEdit.WMPaint(var Message :TWMPaint);
var
PS :TPaintStruct;
psRect :TRect;
DC, slDC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
oCanvas,
sCanvas :TCanvas;
i :Integer;
rSize :TSize;
nMax :Integer;
nLineFirst :Integer;
nLineLast :Integer;
nLineCount :Integer;
cLine :String;
begin
// inherited;
if (FStartCaretPos.cx = 0) and (Text <> '') and (Alignment = taLeftJustify) then
FStartCaretPos := GetTextStart(0);
if NOT WordWrap then begin
slDC := GetDC(Self.Handle);
psRect := Self.ClientRect;
DC := CreateCompatibleDC(slDC);
hbmNew := CreateCompatibleBitmap(slDC, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
sCanvas := TCanvas.Create;
sCanvas.Handle := DC;
sCanvas.Font := Self.Font;
sCanvas.Brush.Color := Self.Color;
sCanvas.FillRect(Self.ClientRect);
FLineCaretPos := GetTextStart(1);
cLine := TextFromLine(1); //Lines[i];
if cLine = '' then cLine :=' ';
rSize := sCanvas.TextExtent(cLine);
PaintLine(sCanvas, cLine, 1, Rect(FLineCaretPos.cx, FLineCaretPos.cy, Self.ClientRect.Right, FLineCaretPos.cy+rSize.cy));
BitBlt(slDC, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
ReleaseDC(Self.Handle,slDC);
DeleteDC(slDC);
sCanvas.Free;
BeginPaint(Handle, PS);
EndPaint(Handle, PS);
end
else 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
nLineCount := SendMessage(Self.Handle, EM_GETLINECOUNT,0,0);
nMax := TopLine()+VisibleLines();
if nMax > nLineCount then nMax := nLineCount;
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;
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, J, Y :Integer;
begin
Y:=0;
J:=1;
with oCanvas do
for X := nFromX to nToX do begin
oCanvas.Pixels[X, nFromY+Y] := clRed;
Y := Y+J;
if Y = 2 then J := -1;
if Y = 0 then J := 1;
end;
end; { DrawUnderline }
procedure Register;
begin
RegisterComponents('Samples', [TColorEdit]);
end; { Register }
end.
Скорее зигзаг получается (так как идет +-1 относительно У. Я думал, там синусоида рисуется, хотя на таких мелких скачках (+- 1) пофигу что рисовать. 
