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

Теперь нужно StalkerSoftware поглядеть на новую версию, если его устроит, то и ладненько.

StalkerSoftware
1) Дело хорошее, но вывода о том, что дублирование кода имеет отрицательный характер, я бы не стал. Таких выводов уже не делаю. Тут Вы рискуете пройти мимо истинной интеграции и прийти к изобретению велосипеда. (По моему можно потентовать всё, что не запотентовано, например колесо +смайл).
2) Как не бился - не могу нормально в мемке позиционировать - задать положение курсора и сделать скрол чтоб видно было. Это думаю не считается у нас лишним функционалом? А так сделано из вполне прагматичных рассуждений...
3) Можно о принципиальном в двух/трёх предложениях? Я, вот, не уловил.

delover

Цитата:

прийти к изобретению велосипеда

Примерно это и было сделано (то что реализовано в самописных контролах с подсветкой я переписал для Мемо).

Цитата:

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

В моей реализации или сам что то лабаешь? Просто у меня нормально все позиционируется, смотри код - все открыто.

Цитата:

Можно о принципиальном в двух/трёх предложениях? Я, вот, не уловил.

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

От себя. Сам недавно по работе делал программку, нужно было на 5 Дельфи сделать нормальную отрисовку виндовых тем (5 дельфи не поддерживает темы), в итоге пока нашел аналогичный компонент с поддержкой тем - уже сам переписал существующий, вернее дописал функционал.

ЗЫ. вроде придумал как сделать правильную отрисовку выделения, завтра выложу код.

ShIvADeSt
Скачал последнюю версию.

Ошибки 2 (пол символа) и 3 (выделение текста), про которые я писал на предыдущей странице остались. Для того, что бы их увидеть достаточно у memo в демке установить не моноширинный фонт (например Arial, 9).

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

data man

Цитата:

Точнее - у меня кусочек скроллируемого текста отображается в верхнем левом углу, остальная область не перерисовывается.

У меня было немного по другому. При скролинге текста средней кнопкой мыши вниз, внизу оставалась какая то старая строка, а остальной текст скролировался до нее.
Причем я это увидел на компе с XP SP3, хотя на другом компе XP SP2 я этого не наблюдал. В последней версии мемки этого уже нет.

delover

Цитата:

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

В принципе все верно.
У меня есть библиотека, которую я начал еще во время D1 и с тех пор постоянно ее понемногу развиваю. В ней, помимо прочих компонент и модулей, есть компоненты наследники TMemo и TEdit, в которых я добавил много свойств, методов, событий для облегчения себе разработки программ.
А у этих наследников (в частности у TEdit) есть свою наследники. Все это хозяйство работает достаточно стабильно и на базе него сделан не один десяток программ.

В последнее время, мои пользователи все чаще стали просить про добавления орфографии в мои программы. И если сама проверка орфографии у меня почти есть (переделал под себя проверку орфографии от RichView, для hunspell, отвязав ее от RichView), то выделения текста для проверки у меня нет. Вот я и думал добавить ее в TEdit и TMemo малой кровью.
Но судя по уже проделанной работе, уважаемого ShIvADeSt, малой кровью там похоже не очень получается.

Цитата:

В моей реализации или сам что то лабаешь?

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


Цитата:

Объясняю за топик стартера - у него есть глобальное приложение

Как я это понимаю...


Цитата:

компонент с поддержкой тем - уже сам переписал существующий,

Сейчас встретился с подобными трудностями. Заметил что нормальное приложение без манифеста меняет рамку окна, а с манифестом в некоторых ситуациях перестаёт просто это делать. Очёвидно что дальше потребуется больше уточнений как и что должно уметь приложение. Поэтому Дельфи 5 настолько для меня священна, что я пожалуй уже и не осмелюсь использовать её для кого-та и кому-та. Только себе.

О принципиальном (в случае стартера) думаю надо глядеть в сторону хэшевых приёмов, а не различий между едитами и граф.контролами.

StalkerSoftware
Насчет орфографии - может это пригодится AutoCorrect Components
Там и для TМemo работает. Если подойдет - в ПМ. (т.к. лежит в CC)
ЗЫ Забыл добавить, что для D7 и выше.

data man

Цитата:

Насчет орфографии - может это пригодится AutoCorrect Components

Почитал описание, посмотрел демку и немного код.

1) Он умеет красить только в наследнике TRichEdit, а в наследниках TMemo и TEdit не умеет. Если я не прав, и он умеет красить текст и для TMemo или TEdit, то поправь меня.

2) Если же говорить про функцию "AutoCorrect", т.е. вводим слово ключ, жмем пробел и ключ разворачивается в некий текст, то эта фишка у меня и так есть в моих наследниках TMemo и TEdit.

Так что, исходя из п.1 он похоже мне не годится. Хотя за ссылку все равно спасибо.

StalkerSoftware
Не - красить вообще не умеет, только авто замену.
А TEdit и TMемо есть

Код:
TEditWithAutoCorrect = class(TEdit)
TMemoWithAutoCorrect = class(TMemo)

data man

Цитата:

Не - красить вообще не умеет, только авто замену.

Красить он все же умеет, но не сам, а средствами самого RichEdit в его наследнике TRichEditWithAutoCorrect.

StalkerSoftware
Хм, мы же TMemo обсуждаем, нет

Итак как и обещал вчера, выкладываю рабочий код с правильным во всех смыслах выделением (все было гораздо проще, я изначально не по тому пути пошел).
http://rapidshare.com/files/274481026/ColorMemo.zip.html
и сам модуль
[more]

Код:
(**
* Highlight with TMemo Impossible? try this...
* by Gon Perez-Jimenez May'04
*
* This is a sample how to work with highlighting within TMemo component by
* using interjected class technique.
*
* Of course, this code is still uncompleted but it works fine for my
* purposes, so, hope you can improve it and use it.
*
*)

unit Unit1;
interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, RichEdit;

type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
LineSt,ColSt,LineEnd,ColEnd :integer;
// Size :TSize;
StartCaretPos :TSize;
procedure CharToCaret(CharPos:integer; var Row,Column:integer);
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 WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
procedure WMMousewheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
procedure PaintLine(Canvas:TCanvas; LineText:string;CurLine:integer; TxtRect:TRect);
protected
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
PosLabel : TLabel;
PosLabel1 : TLabel;
procedure Update_label;
procedure GotoXY (mCol,mLine: Integer );
function Line : Integer;
function Col : Integer;
function TopLine : Integer;
function VisibleLines: Integer;
end;


TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
KeywordList: TListBox;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Memo1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.DFM}

////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car:char):Boolean;
begin
Case Car of
'.', ';', ',', ':', 'Ў', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', 'Ё',' ',
'`', '[', ']', '(', ')', 'є', 'Є', '{', '}', '?', 'ї', '%','=': result := true;
else
result := false;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function NextWord ( var s: String): String;
begin
result := '';
// PrevWord := '';
if s='' then Exit;
if IsSeparator(s[1]) then begin
result := result+s[1];
delete(s,1,1);
end else

{ while(s<>'')and IsSeparator(s[1]) do begin
PrevWord := PrevWord + s[1];
delete(s,1,1);
end;}
while(s<>'') and not IsSeparator(s[1]) do begin
result := result+s[1];
delete(s,1,1);
end;
end;
////////////////////////////////////////////////////////////////////////////////
function IsKeyWord ( s: String ):Boolean;
begin
result := False;
if s='' then Exit;
result := Form1.KeywordList.Items.IndexOf( lowercase(s) ) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////
function IsNumber ( s: String ):Boolean;
var i: Integer;
begin
result := False;
for i:=1 to length(s) do
Case s[i] of
'0'..'9':;
else Exit;
end;
result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
function TMemo.VisibleLines: Integer;
begin
result := Height div ( Abs(Self.Font.Height)+2);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.GotoXY ( mCol,mLine: Integer );
begin
Dec(mLine);
SelStart:=0;
SelLength:=0;
SelStart := mCol+Self.Perform(EM_LINEINDEX, mLine, 0);
SelLength:=0;
SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Update_label;
begin
if PosLabel=nil then Exit;
PosLabel.Caption := '('+IntToStr(Line+1)+','+IntToStr(Col)+')';
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.TopLine : Integer;
begin
Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Line : Integer;
begin
Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Col : Integer;
begin
Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMVScroll(var Message: TWMVScroll);
begin
Update_label;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMEraseBKGND(var Message: TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.CharToCaret(CharPos:integer; var Row,Column:integer);
begin
Row := SendMessage(Self.Handle, EM_LINEFROMCHAR, CharPos, 0)+1;
Column := CharPos - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, CharPos, 0), 0);

end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonUp(var Message: TWMLButtonUp);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMouseMove(var Message: TWMMouseMove);
var
Locked :boolean;
begin
if (Message.Keys and MK_LBUTTON)=0 then inherited else begin
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMouseWheel);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMCHAR(var Message: TWMCHAR);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyUp(var Message: TWMKeyUp);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyDown(Key,Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyUp(Key,Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseDown(Button,Shift,X,Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseUp(Button,Shift,X,Y);
// invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.PaintLine(Canvas:TCanvas; LineText:string; CurLine:integer; TxtRect:TRect);
type
TxtAttr = record
FontColor, BckColor :TColor;
end;
var
i, j, x :integer;
LastFont, LastBck :TColor;
Size :TSize;
t, CurWord :string;
CharsColor :array of TxtAttr;
begin
try
CharToCaret(Self.SelStart,LineSt,ColSt);
CharToCaret(Self.SelStart+Self.SelLength,LineEnd,ColEnd);
with Canvas do begin
x:=TxtRect.Left;
t:=LineText+' ';
SetLength(CharsColor,Length(LineText)+1);
for i:=0 to High(CharsColor) do begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
end;
i:=0;
repeat
CurWord:=NextWord(t);
if CurWord=' ' then begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsKeyWord(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clHighlight;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else
if IsNumber(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=$000000DD;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clBlack;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end;
until CurWord='';
if (CurLine=LineSt) and (ColSt<>ColEnd) and (LineSt=LineEnd) then
for i:=ColSt+1 to ColEnd do begin
CharsColor[i-1].FontColor:=clWhite;
CharsColor[i-1].BckColor:=clNavy;
end;
if (CurLine>LineSt) and (CurLine<LineEnd) then
for i:=1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=clWhite;
CharsColor[i-1].BckColor:=clNavy;
end;
if (CurLine=LineSt) and (LineSt<LineEnd) then
for i:=ColSt+1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=clWhite;
CharsColor[i-1].BckColor:=clNavy;
end;
if (CurLine=LineEnd) and (LineSt<LineEnd) then
for i:=1 to ColEnd do begin
CharsColor[i-1].FontColor:=clWhite;
CharsColor[i-1].BckColor:=clNavy;
end;
CurWord:=LineText[1];
LastFont:=CharsColor[0].FontColor;
LastBck:=CharsColor[0].BckColor;
for i:=2 to Length(LineText) do begin
t:=LineText[i];
if (LastFont<>CharsColor[i-1].FontColor) or (LastBck<>CharsColor[i-1].BckColor) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
Inc(x,Size.cx);
CurWord:='';
LastFont:=CharsColor[i-1].FontColor;
LastBck:=CharsColor[i-1].BckColor;
end;
CurWord:=CurWord+LineText[i];
if i=Length(LineText) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
end;
end;
finally
SetLength(CharsColor,0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMPaint(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
Size :TSize;
Max :Integer;
s : String;
Point :TPoint;
begin
{ inherited;
Exit;}
BeginPaint(Handle, PS);
if (StartCaretPos.cx=0) then begin
GotoXY(0,0);
Windows.GetCaretPos(Point);
StartCaretPos.cx:=Point.x;
StartCaretPos.cy:=Point.y;
end;
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
Canvas:=TCanvas.Create;
try
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
// GetTextExtentPoint32(Canvas.Handle, 'w', 1, Self.Size);
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);

//Limpio la secciуn visible
Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
PaintLine(Canvas,s,i+1,Rect(x,y,Size.cx,y+Size.cy));
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
end;

procedure TMemo.WMPrintClient(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
Size :TSize;
Max :Integer;
s : String;
begin
BeginPaint(Handle, PS);
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
Canvas:=TCanvas.Create;
try
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);

Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
PaintLine(Canvas,s,i+1,Rect(x,y,Size.cx,y+Size.cy));
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
end;

////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
Memo1.PosLabel1 := Label8;
Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1Click(Sender: TObject);
begin
if Memo1.SelLength=0 then Memo1.invalidate;
end;

end.

ShIvADeSt
Теперь просто намного лучше !
И хотя ранее написано

Цитата:

Возможны баги особенно с удалением выделенного текста.

опишу:

В начале любой строки жмем Shift-End, Shift-влево, Del - удаляется вся строка.
То же самое в конце строки с Shift-Home, Shift-вправо, Del

Про свой баг скроллирования умолчу.

data man

Цитата:

В начале любой строки жмем Shift-End, Shift-влево, Del - удаляется вся строка.
То же самое в конце строки с Shift-Home, Shift-вправо, Del

Молодец, у меня если длина строки 1 - то ничего не рисовалось )
В общем в процедуре PaintLine перед строкой
for i:=2 to Length(LineText) do begin
добавить след код

Код:
if Length(LineText)=1 then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;

Цитата:

добавить след код

Теперь все отлично !

Цитата:

что то данное сообщение в Висте и Вынь7 коряво работает

А вот с этим немного поспорю - в других то контролах работает нормально.
Тот же VirtualTreeView - но там используется CMMouseWheel.

P.S. Спасибо за "шапку"

data man

Цитата:

А вот с этим немного поспорю - в других то контролах работает нормально.
Тот же VirtualTreeView - но там используется CMMouseWheel.

Проблема в том, что я не знаю как в новых версиях Дельфи (у тебя явно не 5 версия) сделана обработка этого события. У меня как видно из кода - все просто, если крутнули колесо, то блокируем отрисовку, прокручиваем текст, отрисовываем текст, убираем блокировку. Так что тестируй сам - попробуй поиграть с сообщениями WM_SETREDRAW вместо моих LockWindowUpdate. Или посмотри реализацию в том же листвью

ShIvADeSt
Да, как говорится, стрижка только началась.
А не пора ли сделать из сабжа полноценный компонент ?
А то эти обновления внешнего TLabel изнутри него - как-то это неправильно.

data man

Цитата:

Да, как говорится, стрижка только началась.
А не пора ли сделать из сабжа полноценный компонент ?

Исходники все есть - берите и делайте Я компоненты никогда не писал и не собираюсь. Мне интересна только техническая сторона, а прилизывать и делать готовое решение - скучно

У меня как в ХР так и в семерке отоброжается один баг, если прокрутить курсором за бегунок то внизу у мемо остается отпечаток строки.

Sampron

Цитата:

У меня как в ХР так и в семерке отоброжается один баг, если прокрутить курсором за бегунок то внизу у мемо остается отпечаток строки.

Сделай скриншот и пометь что именно ты имеешь в виду. Просто сейчас у меня если нижня строка невмещается на экран то прорисовывается ее верхняя часть - это или не это ты имеешь ввиду? Поэтому лучше скриншот.

ShIvADeSt
В принципе уже весьма неплохо, да и по сравнению с предыдущей версией код стал проще и уменьшился на 5 кб.


Цитата:

У меня как в ХР так и в семерке отображается один баг, если прокрутить курсором за бегунок то внизу у мемо остается отпечаток строки.

У меня аналогично на XP SP3.
При скролировании вверх и вниз средней кнопкой мыши или клавиатурой все нормально.
Но если потянуть мышкой вниз (а потом можно и вверх) вертикальный ползунок, то внизу мемки остается артефакт в виде части строки.

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

StalkerSoftware

Цитата:

При скролировании вверх и вниз средней кнопкой мыши или клавиатурой все нормально.
Но если потянуть мышкой вниз (а потом можно и вверх) вертикальный ползунок, то внизу мемки остается артефакт в виде части строки.

Поправил, была такая бага.

Цитата:

если у мемки включить и горизонтальный скроллбар, то можно увидеть, что горизонтальный скролинг (хоть мышью, хотя клавой) вообще не работает.

У меня и в мыслях не было, что может быть горизонтальный скролл я его не люблю.
Вот новый код
[more]

Код:
(**
* Highlight with TMemo Impossible? try this...
* by Gon Perez-Jimenez May'04
*
* This is a sample how to work with highlighting within TMemo component by
* using interjected class technique.
*
* Of course, this code is still uncompleted but it works fine for my
* purposes, so, hope you can improve it and use it.
*
*)

unit Unit1;
interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
StartCaretPos :TSize;
HScroll_Pos :integer;
procedure CharToCaret(CharPos:integer; var Row,Column:integer);
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(Canvas:TCanvas; LineText:string;CurLine:integer; TxtRect:TRect);
protected
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
PosLabel : TLabel;
procedure Update_label;
procedure GotoXY (mCol,mLine: Integer );
function Line : Integer;
function Col : Integer;
function TopLine : Integer;
function VisibleLines: Integer;
end;


TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
KeywordList: TListBox;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Memo1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.DFM}

////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car:char):Boolean;
begin
Case Car of
'.', ';', ',', ':', 'Ў', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', 'Ё',' ',
'`', '[', ']', '(', ')', 'є', 'Є', '{', '}', '?', 'ї', '%','=', '<','>': result := true;
else
result := false;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function NextWord ( var s: String): String;
begin
result := '';
// PrevWord := '';
if s='' then Exit;
if IsSeparator(s[1]) then begin
result := result+s[1];
delete(s,1,1);
end else

{ while(s<>'')and IsSeparator(s[1]) do begin
PrevWord := PrevWord + s[1];
delete(s,1,1);
end;}
while(s<>'') and not IsSeparator(s[1]) do begin
result := result+s[1];
delete(s,1,1);
end;
end;
////////////////////////////////////////////////////////////////////////////////
function IsKeyWord ( s: String ):Boolean;
begin
result := False;
if s='' then Exit;
result := Form1.KeywordList.Items.IndexOf( lowercase(s) ) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////
function IsNumber ( s: String ):Boolean;
var i: Integer;
begin
result := False;
for i:=1 to length(s) do
Case s[i] of
'0'..'9':;
else Exit;
end;
result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
function TMemo.VisibleLines: Integer;
begin
result := Height div ( Abs(Self.Font.Height)+2);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.GotoXY ( mCol,mLine: Integer );
begin
Dec(mLine);
SelStart:=0;
SelLength:=0;
SelStart := mCol+Self.Perform(EM_LINEINDEX, mLine, 0);
SelLength:=0;
SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Update_label;
begin
if PosLabel=nil then Exit;
PosLabel.Caption := '('+IntToStr(Line+1)+','+IntToStr(Col)+')';
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.TopLine : Integer;
begin
Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Line : Integer;
begin
Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Col : Integer;
begin
Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMVScroll(var Message: TWMVScroll);
{var
Locked : boolean;}
begin
// Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
// if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMHScroll(var Message: TWMHScroll);
var
ScrollInfo : TScrollInfo;
begin
inherited;
FillChar(ScrollInfo,SizeOf(TScrollInfo),0);
ScrollInfo.cbSize:=SizeOf(TScrollInfo);
ScrollInfo.fMask:=SIF_POS;
GetScrollInfo(Handle,SB_HORZ, ScrollInfo);
case Message.ScrollCode of
SB_TOP: HScroll_Pos:=ScrollInfo.nMin;
SB_BOTTOM: HScroll_Pos:=ScrollInfo.nMax;
SB_THUMBTRACK: HScroll_Pos:=Message.Pos;
SB_THUMBPOSITION: HScroll_Pos:=ScrollInfo.nPos;
else HScroll_Pos:=ScrollInfo.nPos;
end;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
var
Locked : boolean;
begin
Update_label;
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMEraseBKGND(var Message: TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.CharToCaret(CharPos:integer; var Row,Column:integer);
begin
Row := SendMessage(Self.Handle, EM_LINEFROMCHAR, CharPos, 0)+1;
Column := CharPos - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, CharPos, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonUp(var Message: TWMLButtonUp);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMouseMove(var Message: TWMMouseMove);
var
Locked :boolean;
begin
if (Message.Keys and MK_LBUTTON)=0 then inherited else begin
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMouseWheel);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMCHAR(var Message: TWMCHAR);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyUp(var Message: TWMKeyUp);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyDown(Key,Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyUp(Key,Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseDown(Button,Shift,X,Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseUp(Button,Shift,X,Y);
// invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.PaintLine(Canvas:TCanvas; LineText:string; CurLine:integer; TxtRect:TRect);
const
HilightFont = clNavy;
HilightBack = clSilver;
type
TxtAttr = record
FontColor, BckColor :TColor;
end;
var
i, j, x :integer;
LineSt,ColSt,LineEnd,ColEnd :integer;
LastFont, LastBck :TColor;
Size :TSize;
t, CurWord :string;
CharsColor :array of TxtAttr;
begin
try
CharToCaret(Self.SelStart,LineSt,ColSt);
CharToCaret(Self.SelStart+Self.SelLength,LineEnd,ColEnd);
with Canvas do begin
x:=TxtRect.Left;
t:=LineText+' ';
SetLength(CharsColor,Length(LineText)+1);
for i:=0 to High(CharsColor) do begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
end;
i:=0;
repeat
CurWord:=NextWord(t);
if CurWord<>'' then
if CurWord=' ' then begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsKeyWord(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clWhite;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else
if IsSeparator(CurWord[1]) then begin
CharsColor[i].FontColor:=clYellow;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsNumber(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clFuchsia;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clLime;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end;
until CurWord='';
if (CurLine=LineSt) and (ColSt<>ColEnd) and (LineSt=LineEnd) then
for i:=ColSt+1 to ColEnd do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine>LineSt) and (CurLine<LineEnd) then
for i:=1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine=LineSt) and (LineSt<LineEnd) then
for i:=ColSt+1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine=LineEnd) and (LineSt<LineEnd) then
for i:=1 to ColEnd do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
CurWord:=LineText[1];
LastFont:=CharsColor[0].FontColor;
LastBck:=CharsColor[0].BckColor;
if Length(LineText)=1 then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
for i:=2 to Length(LineText) do begin
t:=LineText[i];
if (LastFont<>CharsColor[i-1].FontColor) or (LastBck<>CharsColor[i-1].BckColor) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
Inc(x,Size.cx);
CurWord:='';
LastFont:=CharsColor[i-1].FontColor;
LastBck:=CharsColor[i-1].BckColor;
end;
CurWord:=CurWord+LineText[i];
if i=Length(LineText) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
end;
end;
finally
SetLength(CharsColor,0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMPaint(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
Size :TSize;
Max :Integer;
s : String;
Point :TPoint;
begin
{ inherited;
Exit;}
BeginPaint(Handle, PS);
if (StartCaretPos.cx=0) then begin
GotoXY(0,0);
Windows.GetCaretPos(Point);
StartCaretPos.cx:=Point.x;
StartCaretPos.cy:=Point.y;
end;
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
Canvas:=TCanvas.Create;
try
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
// GetTextExtentPoint32(Canvas.Handle, 'w', 1, Self.Size);
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);

//Limpio la secciуn visible
Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
if Y+Size.cy<=psRect.Bottom then PaintLine(Canvas,s,i+1,Rect(x-HScroll_Pos,y,Size.cx,y+Size.cy));
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
end;

procedure TMemo.WMPrintClient(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
Size :TSize;
Max :Integer;
s : String;
begin
BeginPaint(Handle, PS);
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
Canvas:=TCanvas.Create;
try
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);

Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
PaintLine(Canvas,s,i+1,Rect(x,y,Size.cx,y+Size.cy));
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
end;

////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1Click(Sender: TObject);
begin
if Memo1.SelLength=0 then Memo1.invalidate;
end;

end.

ShIvADeSt
Теперь и на Win7+D2010 никаких багов со скроллированием !
Но цвета раскраски, ИМХО, раньше лучше были

data man

Цитата:

Но цвета раскраски, ИМХО, раньше лучше были

А блин, я у себя сделал раскраску Мемо аля классик Паскаль (с синим фоном) поэтому цвета букв и прочего подгонял под него. Кому надо - добавите переменные для раскраски или просто существующие цвета поправите на свои В любом случае - работает.
PROFIT!

ShIvADeSt

Цитата:

если у мемки включить и горизонтальный скроллбар, то можно увидеть, что горизонтальный скролинг (хоть мышью, хотя клавой) вообще не работает.

У меня и в мыслях не было, что может быть горизонтальный скролл я его не люблю.

А кто его любит, но юзерам горизонтально скролить не запретишь
Ну и кроме того в TEdit только горизонтально скролинг и есть.

А если серьезно, то теперь вертикальный скролинг работает полностью нормально, как его не осуществляй.

А вот горизонтальный скролинг пока нормально не работает.
Ни клавишами курсора, ни Shift+End, ни мышкой.

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

StalkerSoftware

Цитата:

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

Может быть Я проверял только при скролинге за бегунок. Набор текста не проверял.

Как и обещал, теперь горизонтальный скролл работает всегда

[more]

Код:
(**
* Highlight with TMemo Impossible? try this...
* by Gon Perez-Jimenez May'04
*
* This is a sample how to work with highlighting within TMemo component by
* using interjected class technique.
*
* Of course, this code is still uncompleted but it works fine for my
* purposes, so, hope you can improve it and use it.
*
*)

unit Unit1;
interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
StartCaretPos :TSize;
function HScrollPos:integer;
procedure CharToCaret(CharPos:integer; var Row,Column:integer);
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(Canvas:TCanvas; LineText:string;CurLine:integer; TxtRect:TRect);
protected
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
PosLabel : TLabel;
procedure Update_label;
procedure GotoXY (mCol,mLine: Integer );
function Line : Integer;
function Col : Integer;
function TopLine : Integer;
function VisibleLines: Integer;
end;


TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
KeywordList: TListBox;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Memo1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.DFM}

////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car:char):Boolean;
begin
Case Car of
'.', ';', ',', ':', 'Ў', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', 'Ё',' ',
'`', '[', ']', '(', ')', 'є', 'Є', '{', '}', '?', 'ї', '%','=', '<','>': result := true;
else
result := false;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function NextWord ( var s: String): String;
begin
result := '';
// PrevWord := '';
if s='' then Exit;
if IsSeparator(s[1]) then begin
result := result+s[1];
delete(s,1,1);
end else

{ while(s<>'')and IsSeparator(s[1]) do begin
PrevWord := PrevWord + s[1];
delete(s,1,1);
end;}
while(s<>'') and not IsSeparator(s[1]) do begin
result := result+s[1];
delete(s,1,1);
end;
end;
////////////////////////////////////////////////////////////////////////////////
function IsKeyWord ( s: String ):Boolean;
begin
result := False;
if s='' then Exit;
result := Form1.KeywordList.Items.IndexOf( lowercase(s) ) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////
function IsNumber ( s: String ):Boolean;
var i: Integer;
begin
result := False;
for i:=1 to length(s) do
Case s[i] of
'0'..'9':;
else Exit;
end;
result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
function TMemo.VisibleLines: Integer;
begin
result := Height div ( Abs(Self.Font.Height)+2);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.GotoXY ( mCol,mLine: Integer );
begin
Dec(mLine);
SelStart:=0;
SelLength:=0;
SelStart := mCol+Self.Perform(EM_LINEINDEX, mLine, 0);
SelLength:=0;
SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Update_label;
begin
if PosLabel=nil then Exit;
PosLabel.Caption := '('+IntToStr(Line+1)+','+IntToStr(Col)+')';
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.TopLine : Integer;
begin
Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Line : Integer;
begin
Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Col : Integer;
begin
Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMVScroll(var Message: TWMVScroll);
{var
Locked : boolean;}
begin
// Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
// if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.HScrollPos:integer;
var
ScrollInfo : TScrollInfo;
begin
FillChar(ScrollInfo,SizeOf(TScrollInfo),0);
ScrollInfo.cbSize:=SizeOf(TScrollInfo);
ScrollInfo.fMask:=SIF_POS;
GetScrollInfo(Handle,SB_HORZ, ScrollInfo);
Result:=ScrollInfo.nPos;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMHScroll(var Message: TWMHScroll);
begin
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
var
Locked : boolean;
begin
Update_label;
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMEraseBKGND(var Message: TWMERASEBKGND);
begin
// не удалять данную пустую процедуру, иначе будут глюки с изображением
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.CharToCaret(CharPos:integer; var Row,Column:integer);
begin
Row := SendMessage(Self.Handle, EM_LINEFROMCHAR, CharPos, 0)+1;
Column := CharPos - SendMessage(Self.Handle, EM_LINEINDEX, SendMessage(Self.Handle,
EM_LINEFROMCHAR, CharPos, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonUp(var Message: TWMLButtonUp);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMouseMove(var Message: TWMMouseMove);
var
Locked :boolean;
begin
if (Message.Keys and MK_LBUTTON)=0 then inherited else begin
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
Locked:=LockWindowUpdate(Handle);
inherited;
if Locked then LockWindowUpdate(0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMouseWheel);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMCHAR(var Message: TWMCHAR);
var
Locked:boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyDown(var Message: TWMKeyDown);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMKeyUp(var Message: TWMKeyUp);
var
Locked :boolean;
begin
Locked:=LockWindowUpdate(Handle);
inherited;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE);
if Locked then LockWindowUpdate(0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyDown(Key,Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyUp(Key,Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseDown(Button,Shift,X,Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseUp(Button,Shift,X,Y);
// invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.PaintLine(Canvas:TCanvas; LineText:string; CurLine:integer; TxtRect:TRect);
const
HilightFont = clNavy;
HilightBack = clSilver;
type
TxtAttr = record
FontColor, BckColor :TColor;
end;
var
i, j, x :integer;
LineSt,ColSt,LineEnd,ColEnd :integer;
LastFont, LastBck :TColor;
Size :TSize;
t, CurWord :string;
CharsColor :array of TxtAttr;
begin
try
CharToCaret(Self.SelStart,LineSt,ColSt);
CharToCaret(Self.SelStart+Self.SelLength,LineEnd,ColEnd);
with Canvas do begin
x:=TxtRect.Left;
t:=LineText+' ';
SetLength(CharsColor,Length(LineText)+1);
for i:=0 to High(CharsColor) do begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
end;
i:=0;
repeat
CurWord:=NextWord(t);
if CurWord<>'' then
if CurWord=' ' then begin
CharsColor[i].FontColor:=clBlack;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsKeyWord(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clWhite;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else
if IsSeparator(CurWord[1]) then begin
CharsColor[i].FontColor:=clYellow;
CharsColor[i].BckColor:=Self.Color;
Inc(i);
end
else
if IsNumber(CurWord) then begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clFuchsia;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end
else begin
for j:=1 to Length(CurWord) do begin
CharsColor[i+j-1].FontColor:=clLime;
CharsColor[i+j-1].BckColor:=Self.Color;
end;
Inc(i,Length(CurWord));
end;
until CurWord='';
if (CurLine=LineSt) and (ColSt<>ColEnd) and (LineSt=LineEnd) then
for i:=ColSt+1 to ColEnd do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine>LineSt) and (CurLine<LineEnd) then
for i:=1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine=LineSt) and (LineSt<LineEnd) then
for i:=ColSt+1 to Length(LineText) do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
if (CurLine=LineEnd) and (LineSt<LineEnd) then
for i:=1 to ColEnd do begin
CharsColor[i-1].FontColor:=HilightFont;
CharsColor[i-1].BckColor:=HilightBack;
end;
CurWord:=LineText[1];
LastFont:=CharsColor[0].FontColor;
LastBck:=CharsColor[0].BckColor;
if Length(LineText)=1 then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
for i:=2 to Length(LineText) do begin
t:=LineText[i];
if (LastFont<>CharsColor[i-1].FontColor) or (LastBck<>CharsColor[i-1].BckColor) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
Inc(x,Size.cx);
CurWord:='';
LastFont:=CharsColor[i-1].FontColor;
LastBck:=CharsColor[i-1].BckColor;
end;
CurWord:=CurWord+LineText[i];
if i=Length(LineText) then begin
Size:=TextExtent(CurWord);
SetBkMode(Handle, TRANSPARENT);
if LastBck<>Self.Color then begin
Brush.Color:=LastBck;
FillRect(Rect(x,TxtRect.Top,x+Size.cx,TxtRect.Top+Size.cy));
end;
Font:=Self.Font;
Font.Color:=LastFont;
TextOut(x,TxtRect.Top, CurWord);
end;
end;
end;
finally
SetLength(CharsColor,0);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMPaint(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
Size :TSize;
Max :Integer;
s : String;
Point :TPoint;
begin
{ inherited;
Exit;}
BeginPaint(Handle, PS);
if (StartCaretPos.cx=0) then begin
GotoXY(0,0);
Windows.GetCaretPos(Point);
StartCaretPos.cx:=Point.x;
StartCaretPos.cy:=Point.y;
end;
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
Canvas:=TCanvas.Create;
try
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);
Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
if Y+Size.cy<=psRect.Bottom then PaintLine(Canvas,s,i+1,Rect(x-HScrollPos,y,Size.cx,y+Size.cy));
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
end;

procedure TMemo.WMPrintClient(var Message: TWMPaint);
var
PS :TPaintStruct;
DC :HDC;
hbmNew :HBITMAP;
hbmOld :HBITMAP;
Canvas :TCanvas;
i :Integer;
X,Y :Integer;
psRect :TRect;
Size :TSize;
Max :Integer;
s : String;
begin
BeginPaint(Handle, PS);
psRect:=Self.ClientRect;
DC:=CreateCompatibleDC(ps.hdc);
hbmNew := CreateCompatibleBitmap(PS.hdc, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top);
hbmOld := SelectObject(DC, hbmNew);
Canvas:=TCanvas.Create;
try
Canvas.Handle:=DC;
Canvas.Font:=Self.Font;
with Canvas do begin
Max := TopLine+VisibleLines;
if Max>Pred(Lines.Count)then Max := Pred(Lines.Count);

Brush.Color := Self.Color;
FillRect( Self.ClientRect );
Y:=StartCaretPos.cy;
for i:=TopLine to Max do begin
x:=StartCaretPos.cx;
s:=Lines[i];
if s='' then s:=' ';
Size:=TextExtent(s);
PaintLine(Canvas,s,i+1,Rect(x,y,Size.cx,y+Size.cy));
Inc(Y, Size.cy);
end;
end;
finally
BitBlt(PS.hdc, psRect.Left, psRect.Top, psRect.Right - psRect.Left, psRect.Bottom - psRect.Top, dc, 0, 0, SRCCOPY);
SelectObject(DC, hbmOld);
DeleteObject(hbmNew);
DeleteDC(DC);
EndPaint(Handle, PS);
end;
Canvas.Free;
end;

////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1Click(Sender: TObject);
begin
if Memo1.SelLength=0 then Memo1.invalidate;
end;

end.

ShIvADeSt

Ну что, проверил на D7 и D2010 (XP SP2) вроде бы все работает без ошибок и артефактов.

Большое тебе спасибо, за помощь.
Буду теперь, сделанную тобой раскраску, приспосабливать для TEdit.

Я нажимаю alt и после этого окно перестаёт переключать рамку.

Добавлено:
Делаю это даже не в обработчике клика (изменение рамки). Откладываю это на таймер. Но впечатление будь-то хендл окна вцл оказался с другим номером. Либо простое нажатие на алт без надобности считается способом перехода в другое измерение.

delover

Цитата:

Я нажимаю alt и после этого окно перестаёт переключать рамку

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

Похоже, что при нажатии Alt, memo просто теряет фокус ввода.