如何让我的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在组件的构造函数中设置.如果用户愿意,让用户设置.您的控制没有理由要求双缓冲.