Мерцание, будь оно неладно!

← →
klyonov (2004-05-31 21:57) [0]

всем привет!
вот такой вопрос:
решил сделать себе табличку, или даже список, с симпатичным внешним видом (вид a-la ObjectInspector). Однако столкнулся с мерцанием при скроллинге. не помогают ни WM_ERASEBKGND, ни csOpaque, ни Invalidate.
вообще, внешний вид и принцип его отрисовки я заимствовал у Сергея Гурина из его TObjectInspector. однако у него мерцания нет, а у меня есть.
прилагаю исходный код:

unit MyGrid;

interface

type
TCustomMyGrid = class(TCustomControl)
private
FItems: TStringList;
FRowHeight: Integer;
FTopVisibleRow: Integer;
FActiveRow: Integer;
procedure WMEraseBkGnd(var AMessage: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDlgCode(var AMessage: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMVScroll(var AMessage: TWMScroll); message WM_VSCROLL;
protected
procedure CreateParams(var AParams: TCreateParams); override;
procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure Paint; override;
procedure Resize; override;
procedure UpdateScroll;
property VisibleRowCount: Integer read GetVisibleRowCount;
property TopVisibleRow: Integer read FTopVisibleRow write SetTopVisibleRow;
property ActiveRow: Integer read FActiveRow write SetActiveRow;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

implementation

uses Graphics, Math, Types;

{ TCustomMyGrid }

constructor TCustomMyGrid.Create(AOwner: TComponent);
var i: Integer;
begin
ControlStyle := ControlStyle + [csOpaque];
inherited;
Width := 200;
Height := 300;
FItems := TStringList.Create;
FRowHeight := 16;
FBorderStyle := bsSingle;
Color := clBtnFace;
for i := 0 to 50 do
FItems.Add(Format("ITEM %d", [i, i]));
Anchors := [akLeft, akTop, akBottom];
FActiveRow := 10;
end;

procedure TCustomMyGrid.CreateParams(var AParams: TCreateParams);
const BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
begin
inherited;
with AParams do
begin
Style := Style or BorderStyles[FBorderStyle];
if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
begin
Style := Style and not WS_BORDER;
ExStyle := ExStyle or WS_EX_CLIENTEDGE;
end;
end;
with AParams.WindowClass do
Style := Style and (CS_HREDRAW or CS_VREDRAW);
end;

procedure TCustomMyGrid.CreateWnd;
begin
inherited;
UpdateScroll;
end;

destructor TCustomMyGrid.Destroy;
begin
FItems.Free;
inherited;
end;

procedure TCustomMyGrid.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_UP:
begin
ActiveRow := ActiveRow - 1;
if ActiveRow < TopVisibleRow then
TopVisibleRow := TopVisibleRow - 1;
end;
VK_DOWN:
begin
ActiveRow := ActiveRow + 1;
if ActiveRow > TopVisibleRow + VisibleRowCount - 1 then
TopVisibleRow := TopVisibleRow + 1;
end;
end;
end;

procedure TCustomMyGrid.Paint;

procedure DrawLine(AColor: TColor; X0, Y0, X1, Y1: Integer);
begin
with Canvas do
begin
Pen.Color := AColor;
MoveTo(X0, Y0);
LineTo(X1, Y1);
end;
end;

procedure DrawDotLine(AColor: TColor; X0, X1, Y0: Integer);
var i: Integer;
begin
with Canvas do
begin
i := X0;
while i < X1 do
begin
Canvas.Pixels[i, Y0] := AColor;
inc(i, 2);
end;
end;
end;

var i, j, k: Integer;
dx, dy: Integer;
R: TRect;
begin
inherited;
if not HandleAllocated then
Exit;
Canvas.Brush.Color := Color;
Canvas.FillRect(ClientRect);
if FTopVisibleRow + VisibleRowCount > FItems.Count - 1 then
j := FItems.Count - 1
else
j := FTopVisibleRow + VisibleRowCount - 1;
dy := (FRowHeight div 2) - (Canvas.TextHeight("A") div 2) - 1;
k := 0;
for i := FTopVisibleRow to j do
begin
dx := 5;
R := Rect(0, FRowHeight * k + 1, ClientWidth, FRowHeight * (k + 1) - 1);
Canvas.Brush.Color := Color;
Canvas.TextRect(R, dx, FRowHeight * k + 1 + dy, FItems[i]);
// ????????? ??????? ??????
DrawDotLine(clBtnShadow, 0, Width, FRowHeight * (k + 1));
if i = FActiveRow then
begin
R := Rect(-1, FRowHeight * k, ClientWidth + 1, FRowHeight * (k + 1) + 1);
DrawEdge(Canvas.Handle, R, BDR_SUNKEN, BF_TOPLEFT);
DrawEdge(Canvas.Handle, R, BDR_SUNKEN, BF_BOTTOMRIGHT);
end;
inc(k);
end;
end;

procedure TCustomMyGrid.Resize;
begin
inherited;
UpdateScroll;
Invalidate;
end;

procedure TCustomMyGrid.SetActiveRow(const Value: Integer);
begin
if (Value < 0) and (FActiveRow = 0) then
Exit;
if (Value > FItems.Count - 1) and (FActiveRow = FItems.Count - 1) then
Exit;
if FActiveRow = Value then
Exit;
FActiveRow := Value;
if FActiveRow > FItems.Count - 1 then
FActiveRow := FItems.Count - 1;
if FActiveRow < 0 then
FActiveRow := 0;
Invalidate;
end;

procedure TCustomMyGrid.SetTopVisibleRow(const Value: Integer);
begin
if (Value < 0) and (FTopVisibleRow = 0) then
Exit;
if (Value >= FItems.Count - VisibleRowCount) and
(FTopVisibleRow = FItems.Count - VisibleRowCount) then
Exit;
if FTopVisibleRow = Value then
Exit;
FTopVisibleRow := Value;
if FTopVisibleRow < 0 then
FTopVisibleRow := 0;
if FTopVisibleRow >= (FItems.Count - VisibleRowCount) then
FTopVisibleRow := FItems.Count - VisibleRowCount;
UpdateScroll;
Invalidate;
end;

procedure TCustomMyGrid.UpdateScroll;
var AScrollInfo: TScrollInfo;
begin
if not HandleAllocated then
Exit;
AScrollInfo.cbSize := SizeOf(AScrollInfo);
AScrollInfo.fMask := SIF_PAGE or SIF_POS or SIF_RANGE;
AScrollInfo.nMin := 0;
if FItems.Count > VisibleRowCount then
AScrollInfo.nMax := FItems.Count - 1
else
AScrollInfo.nMax := 0;
if AScrollInfo.nMax > 0 then
AScrollInfo.nPage := VisibleRowCount
else
AScrollInfo.nPage := 0;
if (AScrollInfo.nMax > 0) and (FTopVisibleRow > 0) then
begin
AScrollInfo.nPos := FTopVisibleRow;
AScrollInfo.nTrackPos := FTopVisibleRow;
end
else
begin
AScrollInfo.nPos := 0;
AScrollInfo.nTrackPos := 0;
end;
SetScrollInfo(Handle, SB_VERT, AScrollInfo, True);
end;

procedure TCustomMyGrid.WMEraseBkGnd(var AMessage: TWMEraseBkgnd);
begin
AMessage.Result := LRESULT(False);
end;

procedure TCustomMyGrid.WMGetDlgCode(var AMessage: TWMGetDlgCode);
begin
inherited;
AMessage.Result := DLGC_WANTARROWS;
end;

procedure TCustomMyGrid.WMVScroll(var AMessage: TWMScroll);
var AScrollInfo: TScrollInfo;
begin
inherited;
case AMessage.ScrollCode of
SB_LINEUP: TopVisibleRow := TopVisibleRow - 1;
SB_LINEDOWN: TopVisibleRow := TopVisibleRow + 1;
SB_PAGEUP: TopVisibleRow := TopVisibleRow - VisibleRowCount;
SB_PAGEDOWN: TopVisibleRow := TopVisibleRow + VisibleRowCount;
SB_THUMBPOSITION, SB_THUMBTRACK:
begin
AScrollInfo.cbSize := SizeOf(AScrollInfo);
AScrollInfo.fMask := SIF_TRACKPOS;
GetScrollInfo(Handle, SB_VERT, AScrollInfo);
TopVisibleRow := AScrollInfo.nTrackPos;
end;
end;
end;

end.

← →
jack128 © (2004-05-31 22:17) [1]

чесно говоря лень просматривать стролько кода, так что ты лудше сам скажи: DoubleBuffered := True; - имеется? Если нет - вставить (в конструктор)

← →
klyonov (2004-05-31 22:22) [2]

помогло, спасибо!

← →
wicked © (2004-06-11 19:52) [3]

жють... :)
мой совет - при прорисовке в Paint делать проверять на clip по ClipRect (св-во у Canvas) и соответственно не рисовать ненужные части...
плюсы подхода - намного меньше прорисовок и соблюдение идеологии windows (рисовать только то, что необходимо)...
а DoubleBuffered - не панацея...

← →
DVM © (2004-06-11 20:42) [4]

> и соответственно не рисовать ненужные части...

Так все функции Windows и так не рисуют невидимое за пределами области отсечения. Единственное это может сэкономить немного времени на подготовке к рисованию ненужных частей.

← →
wicked © (2004-06-11 22:21) [5]

> Так все функции Windows и так не рисуют невидимое за пределами
> области отсечения.

я говорил в контексте кода процедуры Paint, приведенного в [0]...
тем более, что TCanvas.ClipRect aka GetClipBox вовсе не устанавливает область отсечения, он просто диктует bounding box invalid"ной области, т.е. той, которуй реально и надо перерисовать... никто не мешает нам рисовать во всей клиентской области окна, тем более, что стиль csOpaque как раз это и предполагает - контрол "саботирует" сообщение WM_ERASEBKGND...

← →
jack128 © (2004-06-13 10:15) [6]

> Так все функции Windows и так не рисуют невидимое за пределами
> области отсечения. Единственное это может сэкономить немного
> времени на подготовке к рисованию ненужных частей.

а иногда даже наоборот увеличивает время на анализ того нужно ли рисовать эту часть уили нет ;-)

> TCanvas.ClipRect aka GetClipBox вовсе не устанавливает область
> отсечения, он просто диктует bounding box invalid"ной области,
> т.е. той, которуй реально и надо перерисовать... никто не
> мешает нам рисовать во всей клиентской области окна, тем
> более, что стиль csOpaque как раз это и предполагает - контрол
> "саботирует" сообщение WM_ERASEBKGND...

нечего не понял. Как это СlipRect - не область отсечения, когда я лично проверял - все что выходит за приделы СlipRect"a - не рисуется? И вообще не понимаю, как конторол может рисовать за своими границами - вот что в исходниках говорится по этому поводу:
procedure TWinControl.PaintControls(DC: HDC; First: TControl); begin ... with TControl(FControls[I]) do if (Visible or (csDesigning in ComponentState) and not (csNoDesignVisible in ControlStyle)) and RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then begin if csPaintCopy in Self.ControlState then Include(FControlState, csPaintCopy); SaveIndex := SaveDC(DC); MoveWindowOrg(DC, Left, Top); IntersectClipRect(DC, 0, 0, Width, Height); Perform(WM_PAINT, DC, 0); RestoreDC(DC, SaveIndex); Exclude(FControlState, csPaintCopy); end; ... end;

когда я столько кода дал - мое сообщение удалили :(

> а иногда даже наоборот увеличивает время на анализ того
> нужно ли рисовать эту часть уили нет ;-)

не обязательно... если анализ на нужность занимает гораздо больше времени, то, может, стоит пересмотреть алгоритм рисования?... ;)

> нечего не понял. Как это СlipRect - не область отсечения,
> когда я лично проверял - все что выходит за приделы СlipRect"a
> - не рисуется?

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

← →
Гоша (2004-06-18 00:18) [9]

>vidiv © (14.06.04 13:29) [7]
>когда я столько кода дал - мое сообщение удалили :(

Дык. Ты его размазал на 4 сообщения :))

Мерцание, будь оно неладно! Найти похожие ветки