TCustomControl descendant bileşenim nasıl yanıp sönmeyi keser?

Question

Üzerinde TScrollBar bulunan bir TCustomControl soyundan bileşenli bir grafik var. Sorun, imleci hareket ettirmek için ok tuşuna bastığımda, tüm kanadın kaydırma çubuğunun bölgesi de dahil olmak üzere arka plan renginde boyanması, daha sonra kaydırma çubuğunun yeniden boyanması ve kaydırma çubuğunun titremesidir. Bunu Nasıl Çözebilirim ?

İşte kod.

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. 

Unit1.pas: gerek bileşenini yüklemek veya ana formdaki bir şey koymak sadece kodu kopyalayıp TForm1.FormCreate olay atamak vardır

Answer 1

Yapacağım ilk şeyin, kaydırma çubuğu denetimini kaldırması olduğunu düşünüyorum. Windows hazır kaydırma çubuklarıyla gelir. Sadece onları etkinleştirmeniz gerekiyor.

Dolayısıyla, bileşenden ScrollBar'u kaldırarak başlayın. Kontrol artık bir kaydırma çubuğu vardır,

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

Yippee:

procedure CreateParams(var Params: TCreateParams); override; 

şöyle Uygulanışı: Sonra CreateParams geçersiz kılma ekleyin.

Sonra WM_VSCROLL için bir işleyici eklemek gerekir:

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

Ve bu böyle uygulanacağı:

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; 

Sen kaydırma kodlarının geri kalanını doldurun gerekir.

Ayrıca, bileşeninizin yapıcısına DoubleBuffered ayarlamamanızı öneririm. Kullanıcı isterlerse ayarlayalım. Kontrolünüzün çift tamponlama gerektirmesi için bir sebep yok.