Как заставить мой компонент потомства TCustomControl перестать мерцать?

Question

У меня есть графический компонент TCustomControl потомков с TScrollBar на нем. Проблема в том, что когда я нажимаю клавишу со стрелкой для перемещения курсора, весь холст окрашивается в цвет фона, включая область полосы прокрутки, затем полоса прокрутки перекрашивается и делает мерцание полосы прокрутки. Как я могу это решить?

Вот код. Существует нет необходимости устанавливать компонент или поставить что-то на главной форме, просто скопировать код и назначить TForm1.FormCreate событие:

Unit1.pas

unit Unit1; 

interface 

uses 
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
    Dialogs, SuperList; 

type 
    TForm1 = class(TForm) 
    procedure FormCreate(Sender: TObject); 
    private 
    { Private declarations } 
    public 
    { Public declarations } 
    end; 

var 
    Form1: TForm1; 
    List: TSuperList; 

implementation 

{$R *.dfm} 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
List:=TSuperList.Create(self); 
List.Top:=50; List.Left:=50; 
List.Visible:=true; 
List.Parent:=Form1; 
end; 

end. 

SuperList.pas

unit SuperList; 

interface 

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

type 

    TSuperList = class(TCustomControl) 
    public 
    DX,DY: integer; 
    ScrollBar: TScrollBar; 
    procedure Paint; override; 
    constructor Create(AOwner: TComponent); override; 
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; 
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; 
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; 
    published 
    property OnMouseMove; 
    property OnKeyPress; 
    property OnKeyDown; 
    property Color default clWindow; 
    property TabStop default true; 
    property Align; 
    property DoubleBuffered default true; 
    property BevelEdges; 
    property BevelInner; 
    property BevelKind default bkFlat; 
    property BevelOuter; 
    end; 

procedure Register; 

implementation 

procedure Register; 
begin 
    RegisterComponents('Marus', [TSuperList]); 
end; 

procedure TSuperList.WMGetDlgCode(var Message: TWMGetDlgCode); 
begin 
inherited; 
Message.Result:= Message.Result or DLGC_WANTARROWS; 
end; 

procedure TSuperList.WMKeyDown(var Message: TWMKeyDown); 
begin 
if Message.CharCode=VK_LEFT then begin dec(DX,3); Invalidate; exit; end; 
if Message.CharCode=VK_RIGHT then begin inc(DX,3); Invalidate; exit; end; 
if Message.CharCode=VK_UP then begin dec(DY,3); Invalidate; exit; end; 
if Message.CharCode=VK_DOWN then begin inc(DY,3); Invalidate; exit; end; 
inherited; 
end; 

procedure TSuperList.WMLButtonDown(var Message: TWMLButtonDown); 
begin 
DX:=Message.XPos; 
DY:=Message.YPos; 
SetFocus; 
Invalidate; 
inherited; 
end; 

constructor TSuperList.Create(AOwner: TComponent); 
begin 
inherited; 
DoubleBuffered:=true; 
TabStop:=true; 
Color:=clNone; Color:=clWindow; 
BevelKind:=bkFlat; 
Width:=200; 
Height:=100; 
DX:=5; DY:=50; 
ScrollBar:=TScrollBar.Create(self); 
ScrollBar.Kind:=sbVertical; 
ScrollBar.TabStop:=false; 
ScrollBar.Align:=alRight; 
ScrollBar.Visible:=true; 
ScrollBar.Parent:=self; 
end; 

procedure TSuperList.Paint; 
begin 
Canvas.Brush.Color:=Color; 
Canvas.FillRect(Canvas.ClipRect); 
Canvas.TextOut(10,10,'Press arrow keys !'); 
Canvas.Brush.Color:=clRed; 
Canvas.Pen.Color:=clBlue; 
Canvas.Rectangle(DX,DY,DX+30,DY+20); 
end; 

end. 

Answer 1

Я думаю, что первое, что я хотел бы сделать, это удалить эту панель прокрутки. Windows поставляется с готовыми полосами прокрутки. Вам просто нужно включить их.

Итак, начните с удаления ScrollBar из компонента. Затем добавьте CreateParams переопределение:

procedure CreateParams(var Params: TCreateParams); override; 

осуществить это так:

procedure TSuperList.CreateParams(var Params: TCreateParams); 
begin 
    inherited; 
    Params.Style := Params.Style or WS_VSCROLL; 
end; 

Yippee, элемент управления теперь имеет полосу прокрутки.

Далее вам нужно добавить обработчик для WM_VSCROLL:

procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; 

И это реализовано так:

procedure TSuperList.WMVScroll(var Message: TWMVScroll); 
begin 
    case Message.ScrollCode of 
    SB_LINEUP: 
    begin 
     dec(DY, 3); 
     Invalidate; 
    end; 
    SB_LINEDOWN: 
    begin 
     inc(DY, 3); 
     Invalidate; 
    end; 
    ... 
    end; 
end; 

Вам необходимо заполнить остальную часть кодов прокрутки.

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