» Delphi: Создание простого цветного TMemo или TEdit

ShIvADeSt

Цитата:

на некоторых шрифтах возможны траблы с отображением некоторых букв.

читал, читал! Возможны, да. Но это ж не RichEdit! Так что Бог с ним!


Цитата:

рисовать реально курсивом, но уменьшить размер шрифта

Супер! Так и сделаю! Если не будет сильно бросаться в глаза, то и bold туда же. Жалко, нельзя шаг шрифта 0,5 ввести как в Word'е.

ShIvADeSt

Цитата:

на некоторых шрифтах возможны траблы с отображением некоторых букв.

Только что нашел ссылку, вроде на МСДН: «Чтобы синтезировать букву в полужирном шрифте, система рисует букву дважды: с отправной точки, и снова со сдвигом на один пиксель вправо от отправной точки.»

Там же;
«Чтобы синтезировать букву в курсивном шрифте, система рисует два ряда пикселей внизу символьного знакоместа, перемещает отправную точку на один пиксель вправо, рисует следующие два ряда, и продолжает это до тех пор, пока не нарисует букву. При помощи перемещения пикселей каждая буква показывается сдвинутой вправо. Величина сдвига фрагмента изображения является функцией высоты буквы.»
Сейчас будем оформлять

MikeZ

Цитата:

Чтобы синтезировать букву в курсивном шрифте, система рисует два ряда пикселей внизу символьного знакоместа, перемещает отправную точку на один пиксель вправо, рисует следующие два ряда, и продолжает это до тех пор, пока не нарисует букву. При помощи перемещения пикселей каждая буква показывается сдвинутой вправо. Величина сдвига фрагмента изображения является функцией высоты буквы.»
Сейчас будем оформлять

Чую тормоза получишь Попробуй лучше меньшим шрифтом рисовать - я в ворде сравнивал, почти не видно разницы

ShIvADeSt
На самом деле, тормозов особо не будет - выводишь на 1-й временный холст текст, потом на 2-й копируешь 2-пиксельные полоски 1-го со сдвигом, потом копируешь куда надо. Должно быть быстро. Но мы пойдём другим путём

Я проще метод нашел: если надо вывести текст в координаты (X, Y), то это означает, что выводятся символы текста в координаты (X + Wi, Y), где Wi - сумма ширин всех символов перед i-м. Ширины этих символов мы знаем, каким бы стилем они не выводились. Запоминаем их и переключаемся на тот стиль, что нам нужен. И выводим «новые» символы в те же позиции. Всё Сейчас наваяю.

Наваял. Замечательно вышло
Теперь можно в обработчике задавать вообще любые стили, для выбранного слова они будут приоритетными, перебивая дефолтные. Например, можно для некоего слова отменить дефолтный Bold.

[more=ColorEdit]{****************************************************}
{ }
{ 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);
TUnderLineType = (ulDefault, ulSolidLine, ulDot, ulLittleDot);
TCheckWordEvent = procedure(Sender :TObject; cWordNum, cWordCount :Integer; cWord :String; WordType
:TWordType; var FontColor, BackgroundColor :TColor; var IsUnderline:Boolean;
var UnderLineType : TUnderLineType; var UnderLineColor : TColor; Var FontStyle : TFontStyles) 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 WMPaste(var Message :TWMPaste); message WM_PASTE;
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;ulType : TUnderLineType; ulColor : TColor);

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.WMPaste(var Message :TWMPaste);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or
RDW_NOERASE);
end;

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 DrawNewStyle(X, Y: Integer; AText: String; ACanvas: TCanvas; ANewStyle: TFontStyles);
Var
I, L, W, H, D : Integer;
OldStyle : TFontStyles;
CharLen : Array Of Integer;
Begin
{Текущий стиль}
OldStyle := ACanvas.Font.Style;
SetLength(CharLen, Length(AText) + 1);
{Запоминаем ширины каждого из символов}
For I := 1 To Length(AText) Do
CharLen[I] := ACanvas.TextWidth(AText[I]);
W := ACanvas.TextWidth(AText);
H := ACanvas.TextHeight(AText);

{Применяем новый стиль}
ACanvas.Font.Style := ANewStyle;

If (fsBold In OldStyle) Or (fsItalic In OldStyle) Then
{ликвидируем прерывистость линий при под- или зачеркивании ранее разреженного текста}
If (fsUnderline In ANewStyle) Or (fsStrikeOut In ANewStyle) Then
ACanvas.TextRect(Rect(X, Y, X + W, Y + H), X, Y, StringOfChar(' ', 3 * Length(AText)));

{Компенсация смещения курсива}
If (fsItalic In ANewStyle) And Not (fsItalic In OldStyle) Then
D := -1 * Trunc(0.5 + ACanvas.TextWidth(' ') / 2)
Else
D := 0;

SetBkMode(ACanvas.Handle, Transparent);

{Если нужно вывести текст жирным, то выводим его нестандартно - имеет лучший вид}
If (fsBold In ANewStyle) And Not (fsBold In OldStyle) Then
Begin
ACanvas.Font.Style := ACanvas.Font.Style - [fsBold];
L := 0;
{Посимвольно выводим текст нового стиля в те же позиции}
For I := 1 To Length(AText) Do
Begin
ACanvas.TextOut(1 + X + L + D + (Trunc(0.5 + (CharLen[I] - ACanvas.TextWidth(AText[I])) / 2)), Y, AText[I]);
L := L + CharLen[I];
end;
End;

L := 0;
{Посимвольно выводим текст нового стиля в те же позиции}
For I := 1 To Length(AText) Do
Begin
ACanvas.TextOut(X + L + D + (Trunc(0.5 + (CharLen[I] - ACanvas.TextWidth(AText[I])) / 2)), Y, AText[I]);
L := L + CharLen[I];
End;

{Восстанавливаем старый стиль}
ACanvas.Font.Style := OldStyle;
SetLength(CharLen, 0);
end;

procedure TColorEdit.PaintLine(oCanvas :TCanvas; cLineText :String;
nCurLine :Integer; rTxtRect :TRect);
const
HilightFont = clHighlightText;
HilightBack = clHighlight;

type
TxtAttr = record
FontColor, BckColor :TColor;
Underline :Boolean;
UnderLineType :TUnderLineType;
UnderLineColor :TColor;
FontStyle : TFontStyles;
end; { TxtAttr }

var
i, j, px :Integer;
nLineBeg, nColBeg, nLineEnd, nColEnd :Integer;
LastFont, LastBck :TColor;
LastUnderline :Boolean;
LastUnderLineType :TUnderLineType;
LastUnderLineColor :TColor;
LastFontStyle: TFontStyles;
rSize :TSize;
t, cCurWord :String;
aCharsColor :array of TxtAttr;
evFontColor, evBckColor :TColor;
evUnderline :Boolean;
evUnderLineType :TUnderLineType;
evUnderLineColor :TColor;
evFontStyle : TFontStyles;
TxtOffset :TRect;
CurWordNum, WordCount:Integer;


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;
aCharsColor[i].UnderLineType := ulDefault;
aCharsColor[i].UnderLineColor := clRed;
end; { for }

i := 0;

{>>>}
CurWordNum := 1;
WordCount := -1;
repeat
cCurWord := NextWord(t);
Inc(WordCount);
Until cCurWord = '';
t := cLineText{+' '};

if t = '' Then
if Assigned(FOnCheckWord) then
FOnCheckWord(Self, 0, 0, '', wtText, evFontColor, evBckColor,
evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);
{<<<}

repeat // Проходим по всей строке и задаем для каждого символа его цвет и цвет его фона

cCurWord := NextWord(t);

if cCurWord <> '' then begin

if cCurWord = ' ' then begin

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cCurWord, wtSpace, evFontColor,
evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

aCharsColor[i].FontColor := evFontColor;
aCharsColor[i].BckColor := evBckColor;
aCharsColor[i].Underline := evUnderline;
aCharsColor[i].UnderLineType := evUnderLineType;
aCharsColor[i].UnderLineColor := evUnderLineColor;
aCharsColor[i].FontStyle := evFontStyle;
Inc(i);

end else
if IsSeparator(cCurWord[1]) then begin

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cCurWord, wtSeparator, evFontColor,
evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

aCharsColor[i].FontColor := evFontColor;
aCharsColor[i].BckColor := evBckColor;
aCharsColor[i].Underline := evUnderline;
aCharsColor[i].UnderLineType := evUnderLineType;
aCharsColor[i].UnderLineColor := evUnderLineColor;
aCharsColor[i].FontStyle := evFontStyle;
Inc(i);

end else
if IsNumber(cCurWord) then begin

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cCurWord, wtNumber, evFontColor,
evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

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;
aCharsColor[i+j-1].UnderLineType := evUnderLineType;
aCharsColor[i+j-1].UnderLineColor := evUnderLineColor;
aCharsColor[i+j-1].FontStyle := evFontStyle;
end; { for }

Inc(i, Length(cCurWord));

end else begin // Задаем цвет остального текста

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cCurWord, wtText, evFontColor,
evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

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;
aCharsColor[i+j-1].UnderLineType := evUnderLineType;
aCharsColor[i+j-1].UnderLineColor := evUnderLineColor;
aCharsColor[i+j-1].FontStyle := evFontStyle;
end; { for }

Inc(i, Length(cCurWord));

end; { if }

Inc(CurWordNum);
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 }

if Length(cLineText) = 0 Then
Begin
cCurWord := '';
LastFont := evFontColor;
LastBck := evBckColor;
LastUnderline := evUnderline;
LastUnderLineType := evUnderLineType;
LastUnderLineColor := evUnderLineColor;
LastFontStyle := evFontStyle;
End
else
begin
cCurWord := cLineText[1];
LastFont := aCharsColor[0].FontColor;
LastBck := aCharsColor[0].BckColor;
LastUnderline := aCharsColor[0].Underline;
LastUnderLineType := aCharsColor[0].UnderLineType;
LastUnderLineColor := aCharsColor[0].UnderLineColor;
LastFontStyle := aCharsColor[0].FontStyle;
end;

{if Length(cLineText) = 1 then}
if Length(cCurWord) > 0 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;

DrawNewStyle(px, rTxtRect.Top, cCurWord, oCanvas, LastFontStyle);

{if (fsStrikeOut in LastFontStyle) then Font.Style := Font.Style + [fsStrikeOut]
Else Font.Style := Font.Style - [fsStrikeOut];
if (fsUnderline in LastFontStyle) then Font.Style := Font.Style + [fsUnderline]
Else Font.Style := Font.Style - [fsUnderline];
if (fsBold in LastFontStyle) And Not (fsBold in Font.Style) then
TextOut(px+1, rTxtRect.Top, cCurWord);

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) or
(LastUnderLineType <> aCharsColor[i-1].UnderLineType) Or
(LastUnderLineColor <> aCharsColor[i-1].UnderLineColor) Or
(LastFontStyle <> aCharsColor[i-1].FontStyle) 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;

DrawNewStyle(px, rTxtRect.Top, cCurWord, oCanvas, LastFontStyle);

{if (fsStrikeOut in LastFontStyle) then Font.Style := Font.Style + [fsStrikeOut]
Else Font.Style := Font.Style - [fsStrikeOut];
if (fsUnderline in LastFontStyle) then Font.Style := Font.Style + [fsUnderline]
Else Font.Style := Font.Style - [fsUnderline];
if (fsBold in LastFontStyle) And Not (fsBold in Font.Style) then
TextOut(px+1, rTxtRect.Top, cCurWord);

TextOut(px, rTxtRect.Top, cCurWord);}

if aCharsColor[i-2].Underline then
DrawUnderline(oCanvas, px, rTxtRect.Top+rSize.cy,
px+rSize.cx, aCharsColor[i-2].UnderLineType, aCharsColor[i-2].UnderLineColor);

Inc(px, rSize.cx);

cCurWord := '';
LastBck := aCharsColor[i-1].BckColor;
LastFont := aCharsColor[i-1].FontColor;
LastUnderline := aCharsColor[i-1].Underline;
LastUnderLineType := aCharsColor[i-1].UnderLineType;
LastUnderLineColor := aCharsColor[i-1].UnderLineColor;
LastFontStyle := aCharsColor[i-1].FontStyle;

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;

DrawNewStyle(px, rTxtRect.Top, cCurWord, oCanvas, LastFontStyle);

{if (fsStrikeOut in LastFontStyle) then Font.Style := Font.Style + [fsStrikeOut]
Else Font.Style := Font.Style - [fsStrikeOut];
if (fsUnderline in LastFontStyle) then Font.Style := Font.Style + [fsUnderline]
Else Font.Style := Font.Style - [fsUnderline];
if (fsBold in LastFontStyle) And Not (fsBold in Font.Style) then
TextOut(px+1, rTxtRect.Top, cCurWord);

TextOut(px, rTxtRect.Top, cCurWord);}

if aCharsColor[i-1].Underline then
DrawUnderline(oCanvas, px, rTxtRect.Top+rSize.cy, px+rSize.cx,
aCharsColor[i-1].UnderLineType, aCharsColor[i-1].UnderLineColor);

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;

CaretPt :TPoint;

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];
{>>>}
GetCaretPos(CaretPt);
FLineCaretPos.cx := CaretPt.X - sCanvas.TextWidth(Copy(cLine, 1, Self.SelStart));
{>>>}
//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 :=' ';
if cLine = '' then rSize := TextExtent(' ') else
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 := ' ';
if cLine = '' then rSize := TextExtent(' ') else
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;ulType : TUnderLineType; ulColor : TColor);
var
X, J, Y :Integer;
C:TColor;
S:TPenStyle;

begin

Case ulType Of
ulSolidLine, ulDot:
Begin
C := oCanvas.Pen.Color;
S := oCanvas.Pen.Style;

oCanvas.Pen.Color := ulColor;
Case ulType Of
ulDot:
oCanvas.Pen.Style := psDot;

Else
oCanvas.Pen.Style := psSolid;
End;

oCanvas.MoveTo(nFromX, nFromY);
oCanvas.LineTo(nToX, nFromY);

oCanvas.Pen.Color := C;
oCanvas.Pen.Style := S;
End;

ulLittleDot:
Begin

with oCanvas do
for X := nFromX to nToX do begin
if (X - nFromX) mod 2 = 0 then
oCanvas.Pixels[X, nFromY] := ulColor;
end; { for }

End;

Else
begin

Y := 0;
J := 1;

with oCanvas do
for X := nFromX to nToX do begin
oCanvas.Pixels[X, nFromY+Y] := ulColor;
Y := Y+J;
if Abs(Y) = 1 then J := -1*J;
end; { for }
End;
End;

end; { DrawUnderline }

procedure Register;
begin

RegisterComponents('Samples', [TColorEdit]);

end; { Register }

end.
[/more]

[more=ColorMemo]{****************************************************}
{ }
{ ColorMemo v1.4 }
{ }
{ 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 ColorMemo;

interface

uses
Windows, Messages, Classes, Graphics, StdCtrls;

type
TWordType = (wtSeparator, wtSpace, wtNumber, wtText);
TUnderLineType = (ulDefault, ulSolidLine, ulDot, ulLittleDot);
TCheckWordEvent = procedure(Sender :TObject; cWordNum, cWordCount :Integer; cLineText :string; cLineNum :Integer;
cWord :String; WordType :TWordType; var FontColor, BackgroundColor :TColor; var IsUnderline :Boolean;
var UnderLineType : TUnderLineType; var UnderLineColor : TColor; Var FontStyle : TFontStyles) of object;


TColorMemo = class(TMemo)
private
{ Private declarations }
FStartCaretPos :TSize;
FLineCaretPos :TSize;
FFocusLost :Boolean;
FSeparators :TStrings;
FOnCheckWord :TCheckWordEvent;

function HScrollPos() :Integer;
procedure SetRedraw(Handle :THandle; Flag :Boolean);
procedure CharToCaret(nCharPos :Integer; var nRow, nColumn :Integer);

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; ulType : TUnderLineType; ulColor : TColor);

procedure SetSeparators(const Value :TStrings);

function NextWord(var cStr :String) :String;

function GetTextStart(nRow :Integer) :TSize;

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;

end; { TColorMemo }

procedure Register;

implementation

constructor TColorMemo.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;

end; { Create }

destructor TColorMemo.Destroy;
begin
FSeparators.Free;
inherited;
end; { Destroy }

procedure TColorMemo.SetSeparators(const Value :TStrings);
begin
FSeparators.Assign(Value);
end; { SetSeparators }

function TColorMemo.IsSeparator(cStr :Char) :Boolean;
begin
Result := (FSeparators.IndexOf(cStr) <> -1);
end; { IsSeparator }

function TColorMemo.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 TColorMemo.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 TColorMemo.VisibleLines() :Integer;
begin
Result := (Height div (Abs(Font.Height)+2));
end; { VisibleLines }

procedure TColorMemo.GotoXY(nCol, nLine :Integer);
begin

Dec(nLine);
SelStart := 0;
SelLength := 0;
SelStart := nCol+Perform(EM_LINEINDEX, nLine, 0);
SelLength :=0;

end; { GotoXY }

function TColorMemo.GetTextStart(nRow :Integer) :TSize;
var
ChrInd :Integer;
Res :LResult;

begin

Result.cx := 0;
Result.cy := 0;

if Lines.Count <= 0 then Exit;

case ScrollBars of

ssBoth, ssHorizontal: begin

if HScrollPos() = 0 then begin

ChrInd := SendMessage(Handle, EM_LINEINDEX, nRow, 0);
Res := SendMessage(Handle, EM_POSFROMCHAR, ChrInd, 0);

if Res > 0 then begin
Result.cx := LoWord(Res);
Result.cy := HiWord(Res);
end; { if }

end else begin

ChrInd := SendMessage(Handle, EM_LINEINDEX, nRow, 0);
Res := SendMessage(Handle, EM_POSFROMCHAR, ChrInd, 0);

if Res > 0 then begin
Result.cx := FStartCaretPos.cx-HScrollPos();
Result.cy := HiWord(Res);
end; { if }

end; { if }

end;

ssVertical, ssNone: begin

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;
Result.cy := HiWord(Res);
end; { if }

end;

end; { case }

end; { GetTextStart }

function TColorMemo.TopLine() :Integer;
begin
Result := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end; { TopLine }

function TColorMemo.Line() :Integer;
begin
Result := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
end; { Line }

function TColorMemo.Col() :Integer;
begin
Result := SelStart - SendMessage(Handle, EM_LINEINDEX, SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0), 0);
end; { Col }

function TColorMemo.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; { HScrollPos }

procedure TColorMemo.SetRedraw(Handle :THandle; Flag :Boolean);
begin
SendMessage(Handle, WM_SETREDRAW, Ord(Flag), 0);
end; { SetRedraw }

procedure TColorMemo.WMVScroll(var Message :TWMVScroll);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end; { WMVScroll }

procedure TColorMemo.WMKillFocus(var Message :TWMKillFocus);
begin

try
SetRedraw(Handle, False);
FFocusLost := True;
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
finally
SetRedraw(Handle, True);
end; { try }

end; { WMKillFocus }

procedure TColorMemo.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 TColorMemo.WMHScroll(var Message :TWMHScroll);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end; { WMHScroll }

procedure TColorMemo.WMSize(var Message :TWMSize);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end; { WMSize }

procedure TColorMemo.WMEraseBKGND(var Message :TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end; { WMEraseBKGND }

procedure TColorMemo.WMMove(var Message :TWMMove);
begin
Invalidate;
inherited;
end; { WMMove }

procedure TColorMemo.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 TColorMemo.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 TColorMemo.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 TColorMemo.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 TColorMemo.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 TColorMemo.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 TColorMemo.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 TColorMemo.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 TColorMemo.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 DrawNewStyle(X, Y: Integer; AText: String; ACanvas: TCanvas; ANewStyle: TFontStyles);
Var
I, L, W, H, D : Integer;
OldStyle : TFontStyles;
CharLen : Array Of Integer;
Begin
{Текущий стиль}
OldStyle := ACanvas.Font.Style;
SetLength(CharLen, Length(AText) + 1);
{Запоминаем ширины каждого из символов}
For I := 1 To Length(AText) Do
CharLen[I] := ACanvas.TextWidth(AText[I]);
W := ACanvas.TextWidth(AText);
H := ACanvas.TextHeight(AText);

{Применяем новый стиль}
ACanvas.Font.Style := ANewStyle;

If (fsBold In OldStyle) Or (fsItalic In OldStyle) Then
{ликвидируем прерывистость линий при под- или зачеркивании ранее разреженного текста}
If (fsUnderline In ANewStyle) Or (fsStrikeOut In ANewStyle) Then
ACanvas.TextRect(Rect(X, Y, X + W, Y + H), X, Y, StringOfChar(' ', 3 * Length(AText)));

{Компенсация смещения курсива}
If (fsItalic In ANewStyle) And Not (fsItalic In OldStyle) Then
D := -1 * Trunc(0.5 + ACanvas.TextWidth(' ') / 2)
Else
D := 0;

SetBkMode(ACanvas.Handle, Transparent);

{Если нужно вывести текст жирным, то выводим его нестандартно - имеет лучший вид}
If (fsBold In ANewStyle) And Not (fsBold In OldStyle) Then
Begin
ACanvas.Font.Style := ACanvas.Font.Style - [fsBold];
L := 0;
{Посимвольно выводим текст нового стиля в те же позиции}
For I := 1 To Length(AText) Do
Begin
ACanvas.TextOut(1 + X + L + D + (Trunc(0.5 + (CharLen[I] - ACanvas.TextWidth(AText[I])) / 2)), Y, AText[I]);
L := L + CharLen[I];
end;
End;

L := 0;
{Посимвольно выводим текст нового стиля в те же позиции}
For I := 1 To Length(AText) Do
Begin
ACanvas.TextOut(X + L + D + (Trunc(0.5 + (CharLen[I] - ACanvas.TextWidth(AText[I])) / 2)), Y, AText[I]);
L := L + CharLen[I];
End;

{Восстанавливаем старый стиль}
ACanvas.Font.Style := OldStyle;
SetLength(CharLen, 0);
end;

procedure TColorMemo.PaintLine(oCanvas :TCanvas; cLineText :String; nCurLine :Integer; rTxtRect :TRect);
const
HilightFont = clHighlightText;
HilightBack = clHighlight;

type
TxtAttr = record
FontColor, BckColor :TColor;
Underline :Boolean;
UnderLineType : TUnderLineType;
UnderLineColor : TColor;
FontStyle : TFontStyles;
end; { TxtAttr }

var
i, j, px :Integer;
nLineBeg, nColBeg, nLineEnd, nColEnd :Integer;
LastFont, LastBck :TColor;
LastUnderline :Boolean;
LastUnderLineType :TUnderLineType;
LastUnderLineColor :TColor;
LastFontStyle: TFontStyles;
rSize :TSize;
t, cCurWord :String;
aCharsColor :array of TxtAttr;
evFontColor, evBckColor :TColor;
evUnderline :Boolean;
evUnderLineType :TUnderLineType;
evUnderLineColor:TColor;
evFontStyle : TFontStyles;


CurWordNum, WordCount :Integer;

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;
aCharsColor[i].UnderLineType := ulDefault;
aCharsColor[i].UnderLineColor := clRed;
end; { for }

i := 0;

{>>>}
CurWordNum := 1;
WordCount := -1;
repeat
cCurWord := NextWord(t);
Inc(WordCount);
Until cCurWord = '';
t := cLineText{+' '};

if t = '' Then
if Assigned(FOnCheckWord) then
FOnCheckWord(Self, 0, 0, '', nCurLine, '', wtText, evFontColor, evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);
{<<<}

repeat // Проходим по всей строке и задаем для каждого символа его цвет и цвет его фона

cCurWord := NextWord(t);

if cCurWord <> '' then begin

if cCurWord = ' ' then begin

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cLineText, nCurLine, cCurWord, wtSpace, evFontColor, evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

aCharsColor[i].FontColor := evFontColor;
aCharsColor[i].BckColor := evBckColor;
aCharsColor[i].Underline := evUnderline;
aCharsColor[i].UnderLineType := evUnderLineType;
aCharsColor[i].UnderLineColor := evUnderLineColor;
aCharsColor[i].FontStyle := evFontStyle;
Inc(i);

end else
if IsSeparator(cCurWord[1]) then begin

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cLineText, nCurLine, cCurWord, wtSeparator, evFontColor, evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

aCharsColor[i].FontColor := evFontColor;
aCharsColor[i].BckColor := evBckColor;
aCharsColor[i].Underline := evUnderline;
aCharsColor[i].UnderLineType := evUnderLineType;
aCharsColor[i].UnderLineColor := evUnderLineColor;
aCharsColor[i].FontStyle := evFontStyle;
Inc(i);

end else
if IsNumber(cCurWord) then begin

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cLineText, nCurLine, cCurWord, wtNumber, evFontColor, evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

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;
aCharsColor[i+j-1].UnderLineType := evUnderLineType;
aCharsColor[i+j-1].UnderLineColor := evUnderLineColor;
aCharsColor[i+j-1].FontStyle := evFontStyle;
end; { for }

Inc(i, Length(cCurWord));

end else begin // Задаем цвет остального текста

evFontColor := Self.Font.Color;
evBckColor := Self.Color;
evUnderline := False;
evUnderLineType := ulDefault;
evUnderLineColor := clRed;
evFontStyle := Self.Font.Style;

if Assigned(FOnCheckWord) then
FOnCheckWord(Self, CurWordNum, WordCount, cLineText, nCurLine, cCurWord, wtText, evFontColor, evBckColor, evUnderline, evUnderLineType, evUnderLineColor, evFontStyle);

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;
aCharsColor[i+j-1].UnderLineType := evUnderLineType;
aCharsColor[i+j-1].UnderLineColor := evUnderLineColor;
aCharsColor[i+j-1].FontStyle := evFontStyle;
end; { for }

Inc(i, Length(cCurWord));

end; { if }

Inc(CurWordNum);
end; { if }

until cCurWord = '';

if (Focused) or (not HideSelection) 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 }

If Length(cLineText) = 0 Then
Begin
cCurWord := '';
LastFont := evFontColor;
LastBck := evBckColor;
LastUnderline := evUnderline;
LastUnderLineType := evUnderLineType;
LastUnderLineColor := evUnderLineColor;
LastFontStyle := evFontStyle;
End
Else
begin
cCurWord := cLineText[1];
LastFont := aCharsColor[0].FontColor;
LastBck := aCharsColor[0].BckColor;
LastUnderline := aCharsColor[0].Underline;
LastUnderLineType := aCharsColor[0].UnderLineType;
LastUnderLineColor := aCharsColor[0].UnderLineColor;
LastFontStyle := aCharsColor[0].FontStyle;
End;

{if Length(cLineText) = 1 then}
if Length(cCurWord) > 0 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;

DrawNewStyle(px, rTxtRect.Top, cCurWord, oCanvas, LastFontStyle);

{if (fsStrikeOut in LastFontStyle) then Font.Style := Font.Style + [fsStrikeOut]
Else Font.Style := Font.Style - [fsStrikeOut];
if (fsUnderline in LastFontStyle) then Font.Style := Font.Style + [fsUnderline]
Else Font.Style := Font.Style - [fsUnderline];
if (fsBold in LastFontStyle) And Not (fsBold in Font.Style) then
TextOut(px+1, rTxtRect.Top, cCurWord);

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) or
(LastUnderLineType <> aCharsColor[i-1].UnderLineType) Or
(LastUnderLineColor <> aCharsColor[i-1].UnderLineColor) Or
(LastFontStyle <> aCharsColor[i-1].FontStyle) 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;

DrawNewStyle(px, rTxtRect.Top, cCurWord, oCanvas, LastFontStyle);

{if (fsStrikeOut in LastFontStyle) then Font.Style := Font.Style + [fsStrikeOut]
Else Font.Style := Font.Style - [fsStrikeOut];
if (fsUnderline in LastFontStyle) then Font.Style := Font.Style + [fsUnderline]
Else Font.Style := Font.Style - [fsUnderline];
if (fsBold in LastFontStyle) And Not (fsBold in Font.Style) then
TextOut(px+1, rTxtRect.Top, cCurWord);

TextOut(px, rTxtRect.Top, cCurWord);}

if aCharsColor[i-2].Underline then
DrawUnderline(oCanvas, px, rTxtRect.Top+rSize.cy, px+rSize.cx,
aCharsColor[i-2].UnderLineType, aCharsColor[i-2].UnderLineColor);

Inc(px, rSize.cx);

cCurWord := '';
LastFont := aCharsColor[i-1].FontColor;
LastBck := aCharsColor[i-1].BckColor;
LastUnderline := aCharsColor[i-1].Underline;
LastUnderLineType := aCharsColor[i-1].UnderLineType;
LastUnderLineColor := aCharsColor[i-1].UnderLineColor;
LastFontStyle := aCharsColor[i-1].FontStyle;

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;

DrawNewStyle(px, rTxtRect.Top, cCurWord, oCanvas, LastFontStyle);

{if (fsStrikeOut in LastFontStyle) then Font.Style := Font.Style + [fsStrikeOut]
Else Font.Style := Font.Style - [fsStrikeOut];
if (fsUnderline in LastFontStyle) then Font.Style := Font.Style + [fsUnderline]
Else Font.Style := Font.Style - [fsUnderline];
if (fsBold in LastFontStyle) And Not (fsBold in Font.Style) then
TextOut(px+1, rTxtRect.Top, cCurWord);

TextOut(px, rTxtRect.Top, cCurWord);}

if aCharsColor[i-1].Underline then
DrawUnderline(oCanvas, px, rTxtRect.Top+rSize.cy, px+rSize.cx,
aCharsColor[i-1].UnderLineType, aCharsColor[i-1].UnderLineColor);

end; { if }

end; { for }

end; { with }

finally
SetLength(aCharsColor, 0);
end; { try }

end; { PaintLine }

procedure TColorMemo.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 (Lines.Count > 0) 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

nMax := TopLine()+VisibleLines();

if nMax > Pred(Lines.Count) then
nMax := Pred(Lines.Count);

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 := Lines[i];
if cLine = '' then {cLine :=' ';}rSize := TextExtent(' ') else
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 TColorMemo.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

nMax := TopLine()+VisibleLines();

if nMax > Pred(Lines.Count) then
nMax := Pred(Lines.Count);

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 := Lines[i];
if cLine = '' then {cLine := ' ';} rSize := TextExtent(' ') else
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 TColorMemo.DrawUnderline(oCanvas :TCanvas; nFromX, nFromY, nToX: Integer;
ulType : TUnderLineType; ulColor : TColor);
var
X, J, Y :Integer;
C:TColor;
S:TPenStyle;

begin

Case ulType Of
ulSolidLine, ulDot:
Begin
C := oCanvas.Pen.Color;
S := oCanvas.Pen.Style;

oCanvas.Pen.Color := ulColor;
Case ulType Of
ulDot:
oCanvas.Pen.Style := psDot;

Else
oCanvas.Pen.Style := psSolid;
End;

oCanvas.MoveTo(nFromX, nFromY);
oCanvas.LineTo(nToX, nFromY);

oCanvas.Pen.Color := C;
oCanvas.Pen.Style := S;
End;

ulLittleDot:
Begin

with oCanvas do
for X := nFromX to nToX do begin
if (X - nFromX) mod 2 = 0 then
oCanvas.Pixels[X, nFromY] := ulColor;
end; { for }

End;

Else
begin

Y := 0;
J := 1;

with oCanvas do
for X := nFromX to nToX do begin
oCanvas.Pixels[X, nFromY+Y] := ulColor;
Y := Y+J;
if Abs(Y) = 1 then J := -1*J;
end; { for }
End;
End;

end; { DrawUnderline }

procedure Register;
begin

RegisterComponents('Samples', [TColorMemo]);

end; { Register }

end.[/more]

У меня почему-то ругается "Undeclared identifier TUnderLineType".

MandrataPupa
Unit, наверное, не обновил... Посмотри в исходники, оно там сразу объявлено

Да, вижу, что объявлено. Но таки остальное-то всё прекрасно проглотило. Непонятное явление. Я щас просто поудалял UnderLineType отовсюду - и в вызовах FOnCheckWord и, соответственно, в параметрах TCheckWordEvent. Щас всё заработало. Только вот не могу въехать, как заюзать FontStyle. Что мне туда присвоить, чтобы, допустим, получился жирный курсив?

Добавлено:
Всё, докопался. Базовых знаний не хваталово, приходится хитростью добывать информацию. Посмотрел в отладчике какое значение получилось у фонта, когда поставил для колормемо болд+италик и такое же присвоил для кейворда. Классно получилось!!! Ну теперь этот колормемо вообще замечательная штуковина!!! К стати, можно было и не париться уж тогда с подчёркиванием, если бы сразу стилем озадачиться. Сразу несколько зайцев одним кирпичом убито!

MandrataPupa

Цитата:

Кстати, можно было и не париться уж тогда с подчёркиванием

Не, отдельное подчёркивание сделано разными стилями и служит для другого. Базовое в смысле проверки орфографии нам не подходит и сделано оно только потому, что в TFont.Style исходно присутствует.

MikeZ
ShIvADeSt,
скажите, а вот последний ColorMemo за 10 число - должен так тормозить или я че-то не так делаю?
Думал проблема в чекворде - вообще убрал этот обработчик, думал поможет, но нет. При большом(около 1280х1024) размере Мемо - курсор еле ползает по нему, при мелком (~700х300) более-менее, но тоже не шустро. По диспетчеру видно, что отъедается 100% одного ядра...Компилировал билдером 2009.

pir0texnik2
Откройте AkelPad, загрузите туда любой текстовый документ и прокрутите туда сюда пару раз - загруз будет не меньше. При этом Акель написан на своем контроле, аналогичные тормоза при прокрутке в редакторе дельфи. Последняя версия скорее всего тормозит сильнее, потому что прикручена отрисовка курсива и болда, попробуй на более старых версиях. А так тормоза - нормальное явление.
Если же тормоза при перемещении курсора в рамках одной строки (без прокрутки), то проверяйте на старых версиях - не должно тормозить.

Да, кстати, проблема есть: заключается в том, что ColorMemo (очевидно, в отличии от стандартного) при каждом чихе лезет перерисовываться. Причём, весь. Надо будет смотреть, как перерисовка организована.

ShIvADeSt

Цитата:

Откройте AkelPad, загрузите туда любой текстовый документ и прокрутите туда сюда пару раз - загруз будет не меньше. При этом Акель написан на своем контроле, аналогичные тормоза при прокрутке в редакторе дельфи. Последняя версия скорее всего тормозит сильнее, потому что прикручена отрисовка курсива и болда, попробуй на более старых версиях. А так тормоза - нормальное явление.
Если же тормоза при перемещении курсора в рамках одной строки (без прокрутки), то проверяйте на старых версиях - не должно тормозить.

Алекелпада у меня нет, есть бред - не тормозит, есть редактор билдера/делфи 2009 - тоже не тормозит и еще много разных редакторов с подсветкой - тоже все ок... При развертывании на весь экран, если нажать кнопку скажем вправо, то курсор не скользит по тексту вниз, а прыгает, на небольшом размере мемо курсор движется более-менее плавно, но тоже видно, что подтормаживает. Ну странно, что мощности Q6600 не хватает для отрисовки мемо. Думаю как раз MikeZ прав и как-то нерационально проиходит отрисовка...

попробовал это http://www.stalker4.dp.ua/files/other/ColorMemo.rar - тормозит тоже, но меньше...

MikeZ

Цитата:

Да, кстати, проблема есть: заключается в том, что ColorMemo (очевидно, в отличии от стандартного) при каждом чихе лезет перерисовываться. Причём, весь. Надо будет смотреть, как перерисовка организована.

Все дело в том, что при любом чихе идет апдейт всей области. См RedrawWindow с нулевыми регионами.
Уменьшена загрузка процессора при обычном перемещении по контролу, заменить соотв процедур

Код:
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
function IsShiftDown:boolean;
begin
Result:=(GetKeyState(VK_LSHIFT)<0);
end;
var
Locked : boolean;
begin
if NOT ((Message.CharCode in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) AND NOT IsShiftDown) OR (Self.SelLength>0) then 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
else inherited;
end;

ShIvADeSt

Цитата:

Уменьшена загрузка процессора при обычном перемещении по контролу

Аналогично еще и WMKeyUp и WMChar - может, совсем хорошо будет?

Смотри, еще мысль (по отрисовке только строки): положение каретки мы знаем, можем от неё в обе стороны сплясать и проверить не изменился ли текст справа и слева от неё + осталось ли выделение. И перерисовать строку(-и).

MikeZ
Я могу перерисовать строку, не в этом дело В общем помимо текста есть еще пространство, которое им не заполнено (примерно по 1 пикселю влево, вправо и вверх, плюс пикселей 10 вниз - в зависимости от шрифта). Если первые 3 я смог нормально закрасить, но последний нет. Делал так - при событии WM_CHAR запоминаю строку, которую редактирую. При отрисовки линии сверяю - если отрисовываемая строка не равна редактируемой, то смысл ее рисовать- пропускаю, вместо рисования копирую рисунок старой строки. Но при этом остаются артефакты, если прокрутить в самый низ, то последняя строка дублируется. Есть идея закрашивать внизу кусок от последних 2 строк до самого низа и просто ВСЕГДА рисовать нижние строки. Будет время протестирую.