delphi - 如何使我的 TCustomControl 后代组件停止闪烁？

Question

我有一个图形 TCustomControl 后代组件，其上有一个 TScrollBar。问题是，当我按箭头键移动光标时，整个 Canvas 都被绘制为背景颜色，包括滚动条的区域，然后滚动条被重新绘制，这使得滚动条闪烁。我该如何解决这个问题？

这是代码。无需安装组件或在主窗体上放置任何内容，只需复制代码并分配 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。如果用户愿意，可以让他们设置。您的控件没有理由需要双缓冲。