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

Да нет, я, видимо, нечётко изложил суть проблемы. Как найти конец строки, я знаю. Но, дело в том, что ColorMemo передаёт в ColorMemo1CheckWord только само обрабатываемое слово и его тип. А строка при этом не видна. Как бы мне отследить хотя-бы номер строки, из которой взято данное слово?

Есть процедура PaintLine, в которую передается номер строки. Отредактируйте ColorMemo1CheckWord так чтобы в него передавался номер строки. Просто у меня нет процедуры ColorMemo1CheckWord поэтому я не знаю как она работает.

ShIvADeSt
Проблема с LoWord и координатами длинного текста выплыла и у меня (ХР СП3). Т.к. она системозависима, то, имхо, как-то фиксить её не получится - нельзя заранее узнать, координата -50000 - это глюк или текста много. Поэтому надо вообще от этого уйти и считать координату по-другому. Положение ж самой каретки нам не надо вычислять? А отрисовать текст, имея канву, можно вычислить через длину текста и контрола.

Добавлено:
MandrataPupa
StalkerSoftware
Я бы добавил в onCheckWord несколько параметров, типа строки, её номера, номера слова, типа подчеркивания (не только волнистую), её цвет. Оно будет надо или лучше не влазить со своими правками в чужую стройную конструкцию?

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

ShIvADeSt
Попробую налепить «заплатку»: в WMPAINT'е рассчитать именно х-координату уже после GetTextPos через TextWidth и Align. Но будет некрасиво

Добавлено:
В ColorMemo, как я понял, таких проблем нет?

Надоел я уже тут наверное всем. Однако осмелюсь ещё раз влезть со своими проблемами.
Нельзя ли в ColorMemo сделать, чтобы обработчику OnCheckWord передавалась бы ещё инфа об конце строки? Щас по концу строки обрабатываемое слово cWord равно пробелу. Пусть бы было как есть, #13#10. Дело в том, что мне, допустим, надо покрасить комментарии от ";" до конца строки, а конец-то как раз и никак не отлавливается, что уж я только ни делал. Да и вообще, может быть полезно знать, когда следующая строка начинается. К примеру - захочется, допустим, раскрасить все строки в разный цвет, чтобы легче читалось.

MandrataPupa
Можно, я ж и предложил. Докручу и выложу. Благо, не оч. много и всё за меня сделали.

А лучше бы, наверное всё-таки знать именно номер строки. Это если делать полосатый текст (строка по-темнее, строка по-светлее). А если просто красить подряд тёмная/светлая, то при изменении размера по вертикали и при скроллинге расцветка будет прыгать. А может быть, я и ошибаюсь.

MandrataPupa

Цитата:

Дело в том, что мне, допустим, надо покрасить комментарии от ";" до конца строки, а конец-то как раз и никак не отлавливается, что уж я только ни делал. Да и вообще, может быть полезно знать, когда следующая строка начинается. К примеру - захочется, допустим, раскрасить все строки в разный цвет, чтобы легче читалось.

Это делается другим способов - если найден тег комментария, то прекращаем парсить текст и все красим цветом для комментария.
Полосатый текст тоже по другому делается - в процедуре PaintLine есть номер строки - выставляем бэкграунд в зависимости от четности нечетноси номера и потом уже рисуем на нем.
Но для этого надо вначале разобраться как работает код. А это Вы судя по всему забыли сделать

Цитата:

Но для этого надо вначале разобраться как работает код. А это Вы судя по всему забыли сделать

По правде сказать, да, не разобрался. Но не забыл, а просто пока ещё абсолютно не ориентируюсь в среде. Всего только несколько дней пытаюсь постигнуть дельфи. До этого (ооочень давно!) имел дело только со старинным досовским паскалем. Посему прошу не судить строго. Вот только буквально сию минуту сделал для себя ОТКРЫТИЕ - оказывается есть возможность залезть внутрь процедур TColorMemo. А до этого даже не мог взять в толк, про какую это процедуру PaintLine Вы мне всё время пытаетесь втолковать. Ну теперь-то, будем надеяться, будет возникать меньше дурацких вопросов.

ShIvADeSt
На самом деле, имхо, информация лишней не бывает. Если есть возможность вывода номеров, то что, нам жалко, что ли?

Сделал ColorEdit:
1. Поправил вывод с центральным/правым выравниванием. Тестите.
2. Расширил список параметров, передаваемых в событие для раскраски (+ номер слова, общее кол-во слов)
3. Я совершенно не понял прикола обрабатывать наличие пустого Text в edit'е, заменяя его на пробел, если мы не просто выводим, а как-то обрабатываем текст, например, центрируем его. Убрал все «+' '» из текста и добавил проверки на пустые строки.
4. Я чуть приподнял (т.е. ближе к тексту) подчеркивание. Как по мне, так приятнее смотреть.

новая версия ниже...

Добавлено:
ColorMemo:
1. Расширил список параметров, передаваемых в событие для раскраски (номер слова, кол-во слов, полный текст строки, её номер, тип подчеркивания, его цвет)
2. Расширил варианты подчеркивания (наверное, и в ColorEdit надо добавить)
3. Пофиксил ту же фишку с добавлением пробелов к строкам

новая версия ниже...

UPD: в DrawUnderline в ColorMemo забыл clRed на ulColor заменить. Подправил.

Еще чуток навернул (для ColorEdit и ColorMemo):
1. Опустил обратно позицию подчёркивания
2. Добавил слегка изменяемые для каждого слова стили шрифта:
- подчёркивание и зачёркивание можно добавлять (если не задано для всего контрола) и удалять (если задано);
- жирный можно только добавлять, если такой стиль для всего текста НЕ задан;
- курсив никак не регулируется.

[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 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;

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;

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;

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 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;

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;

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;

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]

А почему бы просто не назначать свой фонт для каждого случая, а не отдельные его свойства? Тут же всё в одном флаконе: и цвет (правда, ограниченный набор) и стиль и шрифт и зачёркивание/подчёркивание и всё остальное.

MandrataPupa

потому, что разный фонт - это разный размер букв. Всё было бы хорошо, но каретка, положение которой рассчитывается от исходного шрифта, начинает «уплывать» от нужного положения и чем больше текст, тем дальше. Поэтому я и Bold не могу отменить.

Попробуй перед строками 847, 881 и 925 (где TextOut) в ColorEdit добавить
Font.Style := Font.Style + [fsItalic];
И потести на длинных строках

Понятненько. А таки жаль. Было бы очень гламурно. Мне так кажется. А если каждый раз от пересчитывать на разный шрифт, это, пожалуй, будет слишком муторно. Ну да ладно. Главное, что есть теперь возможность текст раскрашивать как душа пожелает. В общем и, в том числе, в целом, вещь получилась стоящая

MandrataPupa
Если со шрифтами, то у нас для этого RichEdit есть - там всё можно.

RichEdit кушает только RTF-файлы. Меня это категорически не устраивает.
Вот ещё поковыряюсь с дельфи, наберусь наглости и попытаюсь-таки самостоятельно перетянуть всё на обработку фонтов. Пока ещё слабо себе представляю даже масштаб задачи. Но таки попытаюсь обязательно. Хотя-бы поупражняюсь. Вдруг да получится чевота!

С чего бы?! Возьми RichEdit, сделай ему Lines.LoadFromFile обычный текстовый файл и он его замечательно скушает.

Добавлено:
Со шрифтами, конечно, тоже побалуйся. Только, сдаётся мне, что если еще и size обрабатывать, то там крыша может окончательно не выдержать!

MandrataPupa

Цитата:

Вот ещё поковыряюсь с дельфи, наберусь наглости и попытаюсь-таки самостоятельно перетянуть всё на обработку фонтов.

Не получится. Объясняю в вкратце, чтобы было сделано. Была переписана вся отрисовка для Едита (Мемо в винде это многострочный Едит). Но при этом сам механизм работы - позицонирование каретки и прочее не трогалось. В связи с тем, что Едит не поддерживает разные шрифты, то попытка отрисовывать разные куски текста разным шрифтом чревато некорректной отрисовкой каретки. А это в свою очередь ведет к самому главному, почему я не стал трогать механику работы - отрисовка выделения. Как только вы поломаете стандартный механизм (а отрисовка каретки - это часть этого) готовьтесь к самостоятельной отрисовке выделения для ВСЕХ случаев. Курить начапо топика, там много про это написано - код там же.
Итого, смысл все это городить с Едитом, когда в сети куча примеров реализации поддержки разных шрифтов для РичЕдита - специально заточенный для этого. Если же есть желание написать собственный редактор - то как все нормальные люди делай собственный контрол (Смотри AkelPad или Beam Notepad) либо пиши его на основе. Теорию для написания своего контрола мону дать, сам ее вдумчиво читал, когда дописывал данный контрол. Часть кода оттуда, там правда С++, но это не важно - надо уметь читать любой код.

Благодарю за разъяснение. Ну я просто, как всякий нормальный ламер решил, что мне уже море по колено. Это бывает. На счёт того, чтобы почитать мне эту теорию - боюсь, как бы у меня вообще тогда не отшибло всю охоту осваивать дельфи. Уж про Ц++ даже и не говорю. Буду лучше пока пользоваться тем, что умные люди придумали.
MikeZ, щас попробовал RichEdit. Да, действительно, открывает TXT. Но таки всё равно сохраняет в RTF. Можно как-то заставить его сохранять в TXT?

MandrataPupa
А свойство PlainText поклацать true/false перед сохранением?
Смысл RichEdit'а в том, что в нём можно с текстом (и не только) по-разному изгаляться. Но сохранение в *.txt убьёт всю малину. Так и смысл его брать?

ShIvADeSt
StalkerSoftware
Про начало топика, кстати: киньте ссылкой на прикручивание орфографии, пожалуйста!

MikeZ

Цитата:

Про начало топика, кстати: киньте ссылкой на прикручивание орфографии, пожалуйста!

Я это не делал, меня более интересует программирование на АПИ. В инете наверное инфа есть.

Да я, в основном, к StalkerSoftware. Я уже на прикрученное хотел взглянуть.

MikeZ
До прикручивания орфографии у меня дело так и не дошло пока.

StalkerSoftware
досадно, да..

all
хотелось бы, действительно, со стилями шрифтов что-то забацать. Есть мысли, как italic симулировать? Если и не 100% такой стиль, но хоть как-то обозначить? Как bold сделал: просто вывел то же, но со смещением в 1 пкс.

MikeZ

Цитата:

хотелось бы, действительно, со стилями шрифтов что-то забацать. Есть мысли, как italic симулировать? Если и не 100% такой стиль, но хоть как-то обозначить? Как bold сделал: просто вывел то же, но со смещением в 1 пкс.

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

Цитата:

Как bold сделал: просто вывел то же, но со смещением в 1 пкс.

Не видел как получилось, но боюсь часть букв будет не читаема на некоторых фонтах. Я даже не понимаю честно, нафига так привязались к этому Мемо. Стояла задача сделать синтаксическую подсветку в Мемо. Задача решена. Если же нужен более менее полноценный контрол с более менее полноценной поддержкой различных шрифтов и стилей - РичЕдит наше все. У него врожденная поддержка жирных, курсивов и прочих вкусностей. При этом каретка позиционируется как раз исходя из шрифтов, которые использовались на строке. И делается это на порядок проще и быстрее, чем извращение с Мемо.

ShIvADeSt

Цитата:

Похоже мой пост выше не дошел до понимания

Вообще-то, это моё объяснение, которое я привёл MandrataPupa на середине 7-й страницы Речь не о шрифтах, а о стилях. И то, с ограничением.


Цитата:

Я даже не понимаю честно, нафига так привязались к этому Мемо. Стояла задача сделать синтаксическую подсветку в Мемо. Задача решена.

Тот Memo, на котором решалась эта задача, исходно назывался ColorMemo и имел возможность раскрашивать текст. Ну так уже и до стиля один шаг? Да, в RichEdit, кстати, и подчеркивание на раз делается, но memo ж из спортивного интереса раскрашивали?

MikeZ

Цитата:

Тот Memo, на котором решалась эта задача, исходно назывался ColorMemo и имел возможность раскрашивать текст. Ну так уже и до стиля один шаг?

Нет не один шаг Я же говорю, использование жирного или курсива вместе с обычным текстом чревато некорректным позиционированием каретки. ColorMemo - это просто название класса, он порождем от обычного мемо, а он по сути обычный едит. При этом основные свойства мемо не трогались - шло только подмена отрисовки, то есть все буквы рисовались на тех же местах, как если бы они были в обычном мемо. Теперь представим что у нас идет смесь стилей - часть текста жирная (ширина текста больше к примеру на 2 пикселя), часть курсивом (на 3 пикселя), часть обычная. В итоге мы имеем что каретка при передвижении смещается неправильно. Если ВЕСЬ текст жирный или курсив - то проблемы нет (так как в основном мемо он такой, то каретка движется правильно), а вот если у нас у основного мемо другой стиль, то чревато.

Цитата:

Да, в RichEdit, кстати, и подчеркивание на раз делается, но memo ж из спортивного интереса раскрашивали?

Да мне было интересно, особенно когда на многих форумах читал, что это невозможно. Но при этом я не добавлял функционал, который нельзя добавить - например вывод картинок или урл .
Чтобы понять про что я - попробуй выводить буквы чрез одну жирной и обычной и посмотреть как будет прыгать каретка.

ShIvADeSt
Еще раз: я в курсе про каретку и про все траблы с нею Посмотри, как я «bold» сделал - катретку не трогая.

Вот и спрашиваю: какой такой эффект all мог бы предложить забацать, чтобы буквы как-то на italic стали похожи (или стали бы похожи на что-то, что можно было бы, закрыв глаза, условно принять за italic). Чтобы все стили как-то сэмулировать. Чтобы
Цитата:

при этом основные свойства мемо не трогались

MikeZ

Цитата:

Посмотри, как я «bold» сделал - катретку не трогая.

Я читал и написал уже на некоторых шрифтах возможны траблы с отображением некоторых букв.
Насчет курсива - тут единственное что может подойти, это (закрыв глаза естессно ) рисовать реально курсивом, но уменьшить размер шрифта, то есть рассчитываем ширину буквы с нормальным фонтом, потом начинаем подбирать такой размер, чтобы курсив был такого же размера. Скорее всего на 1 размер меньше надо будет делать. Вплоть до таблицы - от такого до такого размера для курсива берем на 1 меньше, для такого на 2 и тп. То есть нужно вывести курсив, рисуешь его шрифтом на 1 меньше. В принципе аналогично можно и с жирным сделать. Если закрыть глаза на небольшое уменьшение текста, то сойдет.