Meilleure façon de faire non-flickering, mises à jour graphiques segmenté dans Delphi?
j'ai pensé que je pouvais juste jeter cela dehors et juste demander: j'ai vu des commandes Delphi qui sont sans faille en termes d'effets graphiques. Signification: pas de scintillement, mises à jour sectionnées (seulement redessiner la section d'un contrôle qui est marqué comme sale) et défilement lisse.
j'ai codé beaucoup de contrôles graphiques au cours des années, donc je sais À propos de la double buffering, dibs, bitblts et tous les trucs "communs" (j'utilise toujours dibs pour dessiner tout si possible, mais là est un rétroprojecteur). Aussi connaître InvalidateRect et vérifier TCanvas.ClipRect pour le rect qui doit être mis à jour. Malgré toutes ces solutions typiques, je trouve très difficile de créer les mêmes composants de qualité que les composants dits "Developer Express" ou "Razed Components". Si les graphismes sont lisses, vous pouvez parier le clignotement scrollbars (natif), et si les scrollbars et le cadre sont lisses, vous pouvez jurer que le fond clignote pendant le défilement.
y a-t-il une configuration standard de un code pour gérer ça? Une sorte de pratiques exemplaires qui assure une redessination sans heurt de l'ensemble du contrôle, y compris le secteur non client d'un contrôle?
par exemple, voici un contrôle" bare bone " qui prend de la hauteur pour les mises à jour segmentées (seulement retravailler ce qui est nécessaire). Si vous le Créez sur un formulaire, essayez de déplacer une fenêtre au-dessus et regardez-le remplacer les pièces par des couleurs (voir méthode de peinture).
est-ce que quelqu'un a une classe de base similaire qui peut traiter non client zone redessinée sans scintillement?
type
TMyControl = Class(TCustomControl)
private
(* TWinControl: Erase background prior to client-area paint *)
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd);message WM_ERASEBKGND;
Protected
(* TCustomControl: Overrides client-area paint mechanism *)
Procedure Paint;Override;
(* TWinControl: Adjust Win32 parameters for CreateWindow *)
procedure CreateParams(var Params: TCreateParams);override;
public
Constructor Create(AOwner:TComponent);override;
End;
{ TMyControl }
Constructor TMyControl.Create(AOwner:TComponent);
Begin
inherited Create(Aowner);
ControlStyle:=ControlStyle - [csOpaque];
end;
procedure TMyControl.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
(* When a window has this style set, any areas that its
child windows occupy are excluded from the update region. *)
params.ExStyle:=params.ExStyle + WS_CLIPCHILDREN;
(* Exclude VREDRAW & HREDRAW *)
with Params.WindowClass do
Begin
(* When a window class has either of these two styles set,
the window contents will be completely redrawn every time it is
resized either vertically or horizontally (or both) *)
style:=style - CS_VREDRAW;
style:=style - CS_HREDRAW;
end;
end;
procedure TMyControl.Paint;
(* Inline proc: check if a rectangle is "empty" *)
function isEmptyRect(const aRect:TRect):Boolean;
Begin
result:=(arect.Right=aRect.Left) and (aRect.Bottom=aRect.Top);
end;
(* Inline proc: Compare two rectangles *)
function isSameRect(const aFirstRect:TRect;const aSecondRect:TRect):Boolean;
Begin
result:=sysutils.CompareMem(@aFirstRect,@aSecondRect,SizeOf(TRect))
end;
(* Inline proc: This fills the background completely *)
Procedure FullRepaint;
var
mRect:TRect;
Begin
mRect:=getClientRect;
AdjustClientRect(mRect);
Canvas.Brush.Color:=clWhite;
Canvas.Brush.Style:=bsSolid;
Canvas.FillRect(mRect);
end;
begin
(* A full redraw is only issed if:
1. the cliprect is empty
2. the cliprect = clientrect *)
if isEmptyRect(Canvas.ClipRect)
or isSameRect(Canvas.ClipRect,Clientrect) then
FullRepaint else
Begin
(* Randomize a color *)
Randomize;
Canvas.Brush.Color:=RGB(random(255),random(255),random(255));
(* fill "dirty rectangle" *)
Canvas.Brush.Style:=bsSolid;
Canvas.FillRect(canvas.ClipRect);
end;
end;
procedure TMyControl.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
message.Result:=-1;
end;
mise à Jour
je voulais juste ajouter que ce qui a fait l'affaire était une combinaison de:
- ExcludeClipRect () lors du dessin de la zone non-client, de sorte que vous ne chevauchez pas les graphiques dans la zone client
-
attraper le message WMNCCalcSize plutôt que de simplement utiliser le bordersize pour les mesures. J'ai également eu à prendre la hauteur pour les tailles de bord:
XEdge := GetSystemMetrics(SM_CXEDGE); YEdge := GetSystemMetrics(SM_CYEDGE);
-
appelant RedrawWindow () avec les drapeaux suivants chaque fois que vous avez des barres de défilement qui se sont déplacées ou une redimensionnement:
mRect:=ClientRect; mFlags:=rdw_Invalidate or RDW_NOERASE or RDW_FRAME or RDW_INTERNALPAINT or RDW_NOCHILDREN; RedrawWindow(windowhandle,@mRect,0,mFlags);
-
lors de la mise à jour de l'arrière-plan pendant la méthode Paint (), éviter de dessiner sur des objets enfants possibles, comme ceci (voir le RDW_NOCHILDREN mentionné ci-dessus):
for x := 1 to ControlCount do begin mCtrl:=Controls[x-1]; if mCtrl.Visible then Begin mRect:=mCtrl.BoundsRect; ExcludeClipRect(Canvas.Handle, mRect.Left,mRect.Top, mRect.Right,mRect.Bottom); end; end;
Merci pour l'aide les gars!
4 réponses
par exemple, voici un contrôle" bare bone " qui prend de la hauteur pour les mises à jour segmentées (seulement retravailler ce qui est nécessaire). Si vous le Créez sur un formulaire, essayez de déplacer une fenêtre au-dessus et regardez-le remplacer les pièces par des couleurs (voir méthode de peinture).
est-ce que quelqu'un a une classe de base similaire qui peut gérer les redessinages hors zone client sans clignoter?
Eh bien, votre TMyControl n'a pas de zone non client (encore). Si J'ai ajouté BorderWidth := 10;
et maintenant c'est fait. ;)
en général, la zone non client des fenêtres par défaut est peinte automatiquement sans scintillement, y compris les barres de défilement, les titres, etc... (du moins, je ne l'ai pas vu autrement).
si vous voulez peindre votre propre bordure, vous devez gérer WM_NCPAINT. Voir ce code:
unit Unit2;
interface
uses
Classes, Controls, Messages, Windows, SysUtils, Graphics;
type
TMyControl = class(TCustomControl)
private
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
protected
procedure Paint; override;
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner:TComponent);override;
end;
implementation
{ TMyControl }
constructor TMyControl.Create(AOwner:TComponent);
Begin
Randomize;
inherited Create(Aowner);
ControlStyle:=ControlStyle - [csOpaque];
BorderWidth := 10;
Anchors := [akLeft, akTop, akBottom, akRight];
end;
procedure TMyControl.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_CLIPCHILDREN;
with Params.WindowClass do
style := style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TMyControl.Paint;
begin
Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
Canvas.FillRect(Canvas.ClipRect);
end;
procedure TMyControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TMyControl.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
R: TRect;
begin
Message.Result := 0;
if BorderWidth > 0 then
begin
DC := GetWindowDC(Handle);
try
R := ClientRect;
OffsetRect(R, BorderWidth, BorderWidth);
ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
SetRect(R, 0, 0, Width, Height);
Brush.Color := clYellow;
FillRect(DC, R, Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
end.
quelques remarques:
- outrepasser CreateParams au lieu de déclarant virtuel. Attention à l'avertissement du compilateur (bien que je pense/j'espère que c'est une petite erreur).
- vous n'avez pas à vérifier
isEmptyRect
niisSameRect
. SiClipRect
est vide, alors il n'y a rien à tirer. C'est aussi la raison pour laquelle Ne jamais appeler la peinture directement, mais toujours par Invalidate ou l'équivalent. - AdjustClientRect n'est pas nécessaire. Il est appelé à l'interne au besoin.
et en bonus, c'est exactement comme ça que je dessine un composant chessbord:
type
TCustomChessBoard = class(TCustomControl)
private
FBorder: TChessBoardBorder;
FOrientation: TBoardOrientation;
FSquareSize: TSquareSize;
procedure BorderChanged;
procedure RepaintBorder;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
protected
procedure CreateParams(var Params: TCreateParams); override;
function GetClientRect: TRect; override;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
procedure Repaint; override;
end;
const
ColCount = 8;
RowCount = ColCount;
procedure TCustomChessBoard.BorderChanged;
begin
RepaintBorder;
end;
constructor TCustomChessBoard.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
end;
procedure TCustomChessBoard.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
style := style and not (CS_HREDRAW or CS_VREDRAW);
end;
function TCustomChessBoard.GetClientRect: TRect;
begin
Result := Rect(0, 0, FSquareSize * ColCount, FSquareSize * RowCount);
end;
procedure TCustomChessBoard.Paint;
procedure DrawSquare(Col, Row: Integer);
var
R: TRect;
begin
R := Bounds(Col * FSquareSize, Row * FSquareSize, FSquareSize, FSquareSize);
Canvas.Brush.Color := Random(clWhite);
Canvas.FillRect(R);
end;
var
iCol: Integer;
iRow: Integer;
begin
with Canvas.ClipRect do
for iCol := (Left div FSquareSize) to (Right div FSquareSize) do
for iRow := (Top div FSquareSize) to (Bottom div FSquareSize) do
DrawSquare(iCol, iRow);
end;
procedure TCustomChessBoard.Repaint;
begin
inherited Repaint;
RepaintBorder;
end;
procedure TCustomChessBoard.RepaintBorder;
begin
if Visible and HandleAllocated then
Perform(WM_NCPAINT, 0, 0);
end;
procedure TCustomChessBoard.Resize;
begin
Repaint;
inherited Resize;
end;
procedure TCustomChessBoard.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TCustomChessBoard.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
R: TRect;
R2: TRect;
SaveFont: HFONT;
procedure DoCoords(ShiftX, ShiftY: Integer; Alpha, Backwards: Boolean);
const
Format = DT_CENTER or DT_NOCLIP or DT_SINGLELINE or DT_VCENTER;
CoordChars: array[Boolean, Boolean] of Char = (('1', '8'), ('A', 'H'));
var
i: Integer;
C: Char;
begin
C := CoordChars[Alpha, Backwards];
for i := 0 to ColCount - 1 do
begin
DrawText(DC, PChar(String(C)), 1, R, Format);
DrawText(DC, PChar(String(C)), 1, R2, Format);
if Backwards then
Dec(C)
else
Inc(C);
OffsetRect(R, ShiftX, ShiftY);
OffsetRect(R2, ShiftX, ShiftY);
end;
end;
procedure DoBackground(Thickness: Integer; AColor: TColor;
DoPicture: Boolean);
begin
ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
InflateRect(R, Thickness, Thickness);
if DoPicture then
with FBorder.Picture.Bitmap do
BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
Canvas.Handle, R.Left, R.Top, SRCCOPY)
else
begin
Brush.Color := AColor;
FillRect(DC, R, Brush.Handle);
end;
end;
begin
Message.Result := 0;
if BorderWidth > 0 then
with FBorder do
begin
DC := GetWindowDC(Handle);
try
{ BackGround }
R := Rect(0, 0, Self.Width, Height);
InflateRect(R, -Width, -Width);
DoBackground(InnerWidth, InnerColor, False);
DoBackground(MiddleWidth, MiddleColor, True);
DoBackground(OuterWidth, OuterColor, False);
{ Coords }
if CanShowCoords then
begin
ExtSelectClipRgn(DC, 0, RGN_COPY);
SetBkMode(DC, TRANSPARENT);
SetTextColor(DC, ColorToRGB(Font.Color));
SaveFont := SelectObject(DC, Font.Handle);
try
{ Left and right side }
R := Bounds(OuterWidth, Width, MiddleWidth, FSquareSize);
R2 := Bounds(Self.Width - OuterWidth - MiddleWidth, Width,
MiddleWidth, FSquareSize);
DoCoords(0, FSquareSize, FOrientation in [boRotate090, boRotate270],
FOrientation in [boNormal, boRotate090]);
{ Top and bottom side }
R := Bounds(Width, OuterWidth, FSquareSize, MiddleWidth);
R2 := Bounds(Width, Height - OuterWidth - MiddleWidth, FSquareSize,
MiddleWidth);
DoCoords(FSquareSize, 0, FOrientation in [boNormal, boRotate180],
FOrientation in [boRotate090, boRotate180]);
finally
SelectObject(DC, SaveFont);
end;
end;
finally
ReleaseDC(Handle, DC);
end;
end;
end;
le double tampon et les tactiques de dessin fantaisistes ne sont que la moitié de l'histoire. L'autre moitié, certains diraient la moitié la plus critique, est de limiter combien de votre contrôle est invalidé.
Dans vos commentaires, vous mentionnez que vous utilisez RedrawWindow(handle, @R, 0, rdw_Invalidate or rdw_Frame)
. À quoi paramétrez-vous le rectangle R
? Si vous réglez cela sur votre zone client rect, alors vous redessinez toute la zone client de votre contrôle. Lors du défilement, seule une petite partie de vos besoins de contrôle pour être redessiné - la tranche au "bord de fuite" de la direction de défilement. Windows affichera le reste de l'écran zone client à l'écran pour déplacer les pixels existants dans la direction de défilement.
vérifiez également si vous avez mis vos options de fenêtre pour avoir besoin d'un nouveau dessin complet sur scroll. Je ne me souviens pas des noms des drapeaux, mais vous voulez qu'ils soient désactivés Pour que les actions de défilement n'invalident qu'une partie de votre zone client. Je crois que c'est la valeur par défaut de Windows.
même avec le matériel graphique accéléré, moins de travail est plus rapide que plus de travail. Obtenez votre invalider rects au minimum absolu et de réduire le nombre de pixels que vous poussez à travers le bus système.
C'est une question tout à fait ouverte. Beaucoup de conseils et de réponses ont déjà été donnés. Je voudrais en ajouter deux:
- Inclure
csOpaque
dansControlStyle
si vous peignez ClientRect pleinement, - exclure
CS_HREDRAW
etCS_VREDRAW
deParams.WindowClass.Style
dansCreateParams
.
puisque vous êtes particulièrement intéressé à dessiner sur TScrollingWinControl
, je passe les dernières heures sur la réduction du code de une composante de planification de la mienne, pour obtenir seulement la peinture nécessaire et le code de défilement. Ce n'est qu'un exemple et en aucun cas entièrement fonctionnel ou voulu comme saint, mais il pourrait fournir une certaine inspiration:
unit Unit2;
interface
uses
Classes, Controls, Windows, Messages, ComCtrls, Forms, Grids, Math, CommCtrl,
SysUtils, StdCtrls, Graphics, Contnrs;
type
TAwPlanGrid = class;
TContainer = class(TWinControl)
private
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
end;
TScrollEvent = procedure(Sender: TControlScrollBar) of object;
TScroller = class(TScrollingWinControl)
private
FOnScroll: TScrollEvent;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
procedure DoScroll(AScrollBar: TControlScrollBar);
property OnScroll: TScrollEvent read FOnScroll write FOnScroll;
public
constructor Create(AOwner: TComponent); override;
end;
TColumn = class(TCustomControl)
private
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CMControlChange(var Message: TCMControlChange);
message CM_CONTROLCHANGE;
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
TTimeLineHeader = class(TCustomHeaderControl)
protected
procedure SectionResize(Section: THeaderSection); override;
public
constructor Create(AOwner: TComponent); override;
end;
TTimeLineGrid = class(TStringGrid)
private
FOnRowHeightsChanged: TNotifyEvent;
FRowHeightsUpdating: Boolean;
protected
procedure Paint; override;
procedure RowHeightsChanged; override;
property OnRowHeightsChanged: TNotifyEvent read FOnRowHeightsChanged
write FOnRowHeightsChanged;
public
constructor Create(AOwner: TComponent); override;
function CanFocus: Boolean; override;
end;
TTimeLine = class(TContainer)
private
FHeader: TTimeLineHeader;
protected
TimeLineGrid: TTimeLineGrid;
public
constructor Create(AOwner: TComponent); override;
end;
THighwayHeader = class(TCustomHeaderControl)
private
FSectionWidth: Integer;
procedure SetSectionWidth(Value: Integer);
protected
function CreateSection: THeaderSection; override;
procedure SectionResize(Section: THeaderSection); override;
property SectionWidth: Integer read FSectionWidth write SetSectionWidth;
public
procedure AddSection(const AText: String);
constructor Create(AOwner: TComponent); override;
end;
THighwayScroller = class(TScroller)
private
procedure WMHScroll(var Message: TWMScroll); message WM_HSCROLL;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMVScroll(var Message: TWMScroll); message WM_VSCROLL;
protected
procedure PaintWindow(DC: HDC); override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
end;
THighwayColumn = class(TColumn)
end;
THighwayColumns = class(TObject)
private
FHeight: Integer;
FItems: TList;
FParent: TWinControl;
FWidth: Integer;
function Add: THighwayColumn;
function GetItem(Index: Integer): THighwayColumn;
procedure SetHeight(Value: Integer);
procedure SetWidth(Value: Integer);
protected
property Height: Integer read FHeight write SetHeight;
property Items[Index: Integer]: THighwayColumn read GetItem; default;
property Parent: TWinControl read FParent write FParent;
property Width: Integer read FWidth write SetWidth;
public
constructor Create;
destructor Destroy; override;
end;
THighway = class(TContainer)
private
procedure HeaderSectionResized(HeaderControl: TCustomHeaderControl;
Section: THeaderSection);
protected
Columns: THighwayColumns;
Header: THighwayHeader;
Scroller: THighwayScroller;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
TParkingHeader = class(TCustomHeaderControl)
protected
procedure SectionResize(Section: THeaderSection); override;
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent); override;
end;
TParkingScroller = class(TScroller)
public
constructor Create(AOwner: TComponent); override;
end;
TParkingColumn = class(TColumn)
private
FItemHeight: Integer;
procedure SetItemHeight(Value: Integer);
protected
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
public
constructor Create(AOwner: TComponent); override;
property ItemHeight: Integer read FItemHeight write SetItemHeight;
end;
TParking = class(TContainer)
protected
Column: TParkingColumn;
Header: TParkingHeader;
Scroller: TParkingScroller;
procedure PaintWindow(DC: HDC); override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
end;
TPlanItem = class(TGraphicControl)
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
TPlanItems = class(TList)
public
procedure DayHeightChanged(OldDayHeight, NewDayHeight: Integer);
end;
TAwPlanGrid = class(TContainer)
private
FDayHeight: Integer;
FHighway: THighway;
FParking: TParking;
FPlanItems: TPlanItems;
FTimeLine: TTimeLine;
function GetColWidth: Integer;
procedure HighwayScrolled(Sender: TControlScrollBar);
procedure SetColWidth(Value: Integer);
procedure SetDayHeight(Value: Integer);
procedure TimeLineRowHeightsChanged(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure MouseWheelHandler(var Message: TMessage); override;
procedure Test;
property ColWidth: Integer read GetColWidth;
property DayHeight: Integer read FDayHeight;
end;
function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG;
Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; overload;
external msimg32 name 'GradientFill';
implementation
function Round2(Value, Rounder: Integer): Integer;
begin
if Rounder = 0 then Result := Value
else Result := (Value div Rounder) * Rounder;
end;
// Layout:
//
// - PlanGrid
// - TimeLine - Highway - Parking
// - TimeLineHeader - HighwayHeader - ParkingHeader
// - TimeLineGrid - HighwayScroller - ParkingScroller
// - HighwayColumns - ParkingColumn
// - PlanItems - PlanItems
const
DaysPerWeek = 5;
MaxParkingWidth = 300;
MinColWidth = 50;
MinDayHeight = 40;
MinParkingWidth = 60;
DefTimeLineWidth = 85;
DividerColor = "151900920"99A8AC;
DefColWidth = 100;
DefDayHeight = 48;
DefWeekCount = 20;
{ TContainer }
constructor TContainer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
end;
procedure TContainer.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TContainer.PaintWindow(DC: HDC);
begin
{ Eat inherited }
end;
procedure TContainer.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
{ TScroller }
constructor TScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
HorzScrollBar.Tracking := True;
VertScrollBar.Tracking := True;
end;
procedure TScroller.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
function TScroller.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
var
Delta: Integer;
begin
with VertScrollBar do
begin
Delta := Increment;
if WheelDelta > 0 then
Delta := -Delta;
if ssCtrl in Shift then
Delta := DaysPerWeek * Delta;
Position := Min(Round2(Range - ClientHeight, Increment), Position + Delta);
end;
DoScroll(VertScrollBar);
Result := True;
end;
procedure TScroller.DoScroll(AScrollBar: TControlScrollBar);
begin
if Assigned(FOnScroll) then
FOnScroll(AScrollBar);
end;
procedure TScroller.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
{ TColumn }
procedure TColumn.CMControlChange(var Message: TCMControlChange);
begin
inherited;
if Message.Inserting then
Message.Control.Width := Width;
end;
constructor TColumn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
end;
procedure TColumn.Paint;
type
PTriVertex = ^TTriVertex;
TTriVertex = packed record
X: DWORD;
Y: DWORD;
Red: WORD;
Green: WORD;
Blue: WORD;
Alpha: WORD;
end;
var
Vertex: array[0..1] of TTriVertex;
GRect: TGradientRect;
begin
Vertex[0].X := 0;
Vertex[0].Y := Canvas.ClipRect.Top;
Vertex[0].Red := $DD00;
Vertex[0].Green := $DD00;
Vertex[0].Blue := $DD00;
Vertex[0].Alpha := 0;
Vertex[1].X := Width;
Vertex[1].Y := Canvas.ClipRect.Bottom;
Vertex[1].Red := $FF00;
Vertex[1].Green := $FF00;
Vertex[1].Blue := $FF00;
Vertex[1].Alpha := 0;
GRect.UpperLeft := 0;
GRect.LowerRight := 1;
GradientFill(Canvas.Handle, @Vertex, 2, @GRect, 1, GRADIENT_FILL_RECT_H);
end;
procedure TColumn.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
{ TTimeLineHeader }
constructor TTimeLineHeader.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
DoubleBuffered := True;
Sections.Add;
Sections[0].MinWidth := 40;
Sections[0].Width := DefTimeLineWidth;
Sections[0].MaxWidth := DefTimeLineWidth;
Sections[0].Text := '2011';
end;
procedure TTimeLineHeader.SectionResize(Section: THeaderSection);
begin
if HasParent then
Parent.Width := Section.Width;
inherited SectionResize(Section);
end;
{ TTimeLineGrid }
function TTimeLineGrid.CanFocus: Boolean;
begin
Result := False;
end;
constructor TTimeLineGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akTop, akRight, akBottom];
BorderStyle := bsNone;
ColCount := 2;
ColWidths[0] := 85;
ControlStyle := [csOpaque];
FixedCols := 1;
FixedRows := 0;
GridLineWidth := 0;
Options := [goFixedHorzLine, goRowSizing];
ScrollBars := ssNone;
TabStop := False;
Cells[0, 4] := 'Drag day height';
end;
procedure TTimeLineGrid.Paint;
begin
inherited Paint;
with Canvas do
if ClipRect.Right >= Width - 1 then
begin
Pen.Color := DividerColor;
MoveTo(Width - 1, ClipRect.Top);
LineTo(Width - 1, ClipRect.Bottom);
end;
end;
procedure TTimeLineGrid.RowHeightsChanged;
begin
inherited RowHeightsChanged;
if Assigned(FOnRowHeightsChanged) and (not FRowHeightsUpdating) then
try
FRowHeightsUpdating := True;
FOnRowHeightsChanged(Self);
finally
FRowHeightsUpdating := False;
end;
end;
{ TTimeLine }
constructor TTimeLine.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alLeft;
Width := DefTimeLineWidth;
Height := 100;
FHeader := TTimeLineHeader.Create(Self);
FHeader.Parent := Self;
TimeLineGrid := TTimeLineGrid.Create(Self);
TimeLineGrid.RowCount := DefWeekCount * DaysPerWeek;
TimeLineGrid.SetBounds(0, FHeader.Height, Width, Height - FHeader.Height);
TimeLineGrid.Parent := Self;
end;
{ THighwayHeader }
procedure THighwayHeader.AddSection(const AText: String);
begin
with THeaderSection(Sections.Add) do
Text := AText;
end;
constructor THighwayHeader.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight];
ControlStyle := [csOpaque];
DoubleBuffered := True;
FullDrag := False;
end;
function THighwayHeader.CreateSection: THeaderSection;
begin
Result := THeaderSection.Create(Sections);
Result.MinWidth := MinColWidth;
Result.Width := FSectionWidth;
end;
procedure THighwayHeader.SectionResize(Section: THeaderSection);
begin
SectionWidth := Section.Width;
inherited SectionResize(Section);
end;
procedure THighwayHeader.SetSectionWidth(Value: Integer);
var
i: Integer;
begin
if FSectionWidth <> Value then
begin
FSectionWidth := Value;
for i := 0 to Sections.Count - 1 do
Sections[i].Width := FSectionWidth;
end;
end;
{ THighwayScroller }
constructor THighwayScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight, akBottom];
ControlStyle := [csOpaque];
end;
procedure THighwayScroller.PaintWindow(DC: HDC);
begin
if ControlCount > 0 then
ExcludeClipRect(DC, 0, 0, ControlCount * Controls[0].Width,
Controls[0].Height);
FillRect(DC, ClientRect, Brush.Handle);
end;
procedure THighwayScroller.Resize;
begin
with VertScrollBar do
Position := Round2(Position, Increment);
DoScroll(HorzScrollBar);
DoScroll(VertScrollBar);
inherited Resize;
end;
procedure THighwayScroller.WMHScroll(var Message: TWMScroll);
begin
inherited;
DoScroll(HorzScrollBar);
end;
procedure THighwayScroller.WMPaint(var Message: TWMPaint);
begin
ControlState := ControlState + [csCustomPaint];
inherited;
ControlState := ControlState - [csCustomPaint];
end;
procedure THighwayScroller.WMVScroll(var Message: TWMScroll);
var
NewPos: Integer;
begin
NewPos := Round2(Message.Pos, VertScrollBar.Increment);
Message.Pos := NewPos;
inherited;
with VertScrollBar do
if Position <> NewPos then
Position := Round2(Position, Increment);
DoScroll(VertScrollBar);
end;
{ THighwayColumns }
function THighwayColumns.Add: THighwayColumn;
var
Index: Integer;
begin
Result := THighwayColumn.Create(nil);
Index := FItems.Add(Result);
Result.SetBounds(Index * FWidth, 0, FWidth, FHeight);
Result.Parent := FParent;
end;
constructor THighwayColumns.Create;
begin
FItems := TObjectList.Create(True);
end;
destructor THighwayColumns.Destroy;
begin
FItems.Free;
inherited Destroy;
end;
function THighwayColumns.GetItem(Index: Integer): THighwayColumn;
begin
Result := FItems[Index];
end;
procedure THighwayColumns.SetHeight(Value: Integer);
var
i: Integer;
begin
if FHeight <> Value then
begin
FHeight := Value;
for i := 0 to FItems.Count - 1 do
Items[i].Height := FHeight;
end;
end;
procedure THighwayColumns.SetWidth(Value: Integer);
var
i: Integer;
begin
if FWidth <> Value then
begin
FWidth := Max(MinColWidth, Value);
for i := 0 to FItems.Count - 1 do
with Items[i] do
SetBounds(Left + (FWidth - Width) * i, 0, FWidth, FHeight);
end;
end;
{ THighway }
constructor THighway.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alClient;
Width := 100;
Height := 100;
Header := THighwayHeader.Create(Self);
Header.SetBounds(0, 0, Width, Header.Height);
Header.OnSectionResize := HeaderSectionResized;
Header.Parent := Self;
Scroller := THighwayScroller.Create(Self);
Scroller.SetBounds(0, Header.Height, Width, Height - Header.Height);
Scroller.Parent := Self;
Columns := THighwayColumns.Create;
Columns.Parent := Scroller;
end;
destructor THighway.Destroy;
begin
Columns.Free;
inherited Destroy;
end;
procedure THighway.HeaderSectionResized(HeaderControl: TCustomHeaderControl;
Section: THeaderSection);
begin
Columns.Width := Section.Width;
Scroller.HorzScrollBar.Increment := Columns.Width;
Header.Left := -Scroller.HorzScrollBar.Position;
end;
{ TParkingHeader }
const
BlindWidth = 2000;
constructor TParkingHeader.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight];
ControlStyle := [csOpaque];
DoubleBuffered := True;
Sections.Add;
Sections[0].Width := BlindWidth;
Sections.Add;
Sections[1].AutoSize := True;
Sections[1].Text := 'Parked';
end;
procedure TParkingHeader.SectionResize(Section: THeaderSection);
begin
if (Section.Index = 0) and HasParent then
begin
Parent.Width := Max(MinParkingWidth,
Min(Parent.Width - Section.Width + BlindWidth, MaxParkingWidth));
Section.Width := BlindWidth;
Sections[1].Width := Parent.Width - 2;
end;
inherited SectionResize(Section);
end;
procedure TParkingHeader.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
if HasParent then
begin
SetBounds(-BlindWidth + 2, 0, BlindWidth + Parent.Width, Height);
Sections[1].Width := Parent.Width - 2;
end;
end;
{ TParkingScroller }
constructor TParkingScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight, akBottom];
ControlStyle := [csOpaque];
HorzScrollBar.Visible := False;
VertScrollBar.Increment := DefDayHeight;
end;
{ TParkingColumn }
function TParkingColumn.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
if HasParent then
NewHeight := Max(Parent.Height, ControlCount * FItemHeight);
Result := True;
end;
constructor TParkingColumn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alTop;
AutoSize := True;
FItemHeight := DefDayHeight;
end;
procedure TParkingColumn.SetItemHeight(Value: Integer);
var
i: Integer;
begin
if FItemHeight <> Value then
begin
FItemHeight := Value;
for i := 0 to ControlCount - 1 do
Controls[i].Height := FItemHeight;
TScroller(Parent).VertScrollBar.Increment := FItemHeight;
end;
end;
{ TParking }
constructor TParking.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alRight;
Width := 120;
Height := 100;
Header := TParkingHeader.Create(Self);
Header.Parent := Self;
Scroller := TParkingScroller.Create(Self);
Scroller.SetBounds(1, Header.Height, Width, Height - Header.Height);
Scroller.Parent := Self;
Column := TParkingColumn.Create(Self);
Column.Parent := Scroller;
end;
procedure TParking.PaintWindow(DC: HDC);
var
R: TRect;
begin
Brush.Color := DividerColor;
SetRect(R, 0, Header.Height, 1, Height);
FillRect(DC, R, Brush.Handle);
end;
procedure TParking.Resize;
begin
Column.AdjustSize;
inherited Resize;
end;
{ TPlanItem }
constructor TPlanItem.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Anchors := [akLeft, akTop, akRight];
ControlStyle := [csOpaque];
Color := Random(clWhite);
end;
procedure TPlanItem.Paint;
begin
Canvas.Brush.Color := Color;
Canvas.FillRect(Canvas.ClipRect);
end;
{ TPlanItems }
procedure TPlanItems.DayHeightChanged(OldDayHeight, NewDayHeight: Integer);
var
i: Integer;
begin
for i := 0 to Count - 1 do
with TPlanItem(Items[i]) do
if not (Parent is TParkingColumn) then
begin
Top := Trunc(Top * (NewDayHeight / OldDayHeight));
Height := Trunc(Height * (NewDayHeight / OldDayHeight));
end;
end;
{ TAwPlanGrid }
constructor TAwPlanGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
TabStop := True;
Width := 400;
Height := 200;
FTimeLine := TTimeLine.Create(Self);
FTimeLine.TimeLineGrid.OnRowHeightsChanged := TimeLineRowHeightsChanged;
FTimeLine.Parent := Self;
FParking := TParking.Create(Self);
FParking.Parent := Self;
FHighway := THighway.Create(Self);
FHighway.Scroller.OnScroll := HighwayScrolled;
FHighway.Parent := Self;
FPlanItems := TPlanItems.Create;
SetColWidth(DefColWidth);
SetDayHeight(DefDayHeight);
FHighway.Columns.Height := DefWeekCount * DaysPerWeek * FDayHeight;
end;
destructor TAwPlanGrid.Destroy;
begin
FPlanItems.Free;
inherited Destroy;
end;
function TAwPlanGrid.GetColWidth: Integer;
begin
Result := FHighway.Columns.Width;
end;
procedure TAwPlanGrid.HighwayScrolled(Sender: TControlScrollBar);
begin
if Sender.Kind = sbVertical then
FTimeLine.TimeLineGrid.TopRow := Sender.Position div FDayHeight
else
begin
FHighway.Header.Left := -Sender.Position;
FHighway.Header.Width := FHighway.Width + Sender.Position;
end;
end;
procedure TAwPlanGrid.MouseWheelHandler(var Message: TMessage);
var
X: Integer;
begin
with Message do
begin
X := ScreenToClient(SmallPointToPoint(TCMMouseWheel(Message).Pos)).X;
if X >= FParking.Left then
Result := FParking.Scroller.Perform(CM_MOUSEWHEEL, WParam, LParam)
else
Result := FHighway.Scroller.Perform(CM_MOUSEWHEEL, WParam, LParam);
end;
if Message.Result = 0 then
inherited MouseWheelHandler(Message);
end;
procedure TAwPlanGrid.SetColWidth(Value: Integer);
begin
if ColWidth <> Value then
begin
FHighway.Columns.Width := Value;
FHighway.Header.SectionWidth := ColWidth;
FHighway.Scroller.HorzScrollBar.Increment := ColWidth;
end;
end;
procedure TAwPlanGrid.SetDayHeight(Value: Integer);
var
OldDayHeight: Integer;
begin
if FDayHeight <> Value then
begin
OldDayHeight := FDayHeight;
FDayHeight := Max(MinDayHeight, Round2(Value, 4));
FTimeLine.TimeLineGrid.DefaultRowHeight := FDayHeight;
FHighway.Columns.Height := DefWeekCount * DaysPerWeek * FDayHeight;
FHighway.Scroller.VertScrollBar.Increment := FDayHeight;
FPlanItems.DayHeightChanged(OldDayHeight, FDayHeight);
end;
end;
procedure TAwPlanGrid.Test;
var
i: Integer;
PlanItem: TPlanItem;
begin
Randomize;
Anchors := [akLeft, akTop, akBottom, akRight];
for i := 0 to 3 do
FHighway.Columns.Add;
FHighway.Header.AddSection('Drag col width');
FHighway.Header.AddSection('Column 2');
FHighway.Header.AddSection('Column 3');
FHighway.Header.AddSection('Column 4');
for i := 0 to 9 do
begin
PlanItem := TPlanItem.Create(Self);
PlanItem.Parent := FParking.Column;
PlanItem.Top := i * DefDayHeight;
PlanItem.Height := DefDayHeight;
FPlanItems.Add(PlanItem);
end;
for i := 0 to 3 do
begin
PlanItem := TPlanItem.Create(Self);
PlanItem.Parent := FHighway.Columns[i];
PlanItem.Top := (i + 3) * DefDayHeight;
PlanItem.Height := DefDayHeight;
FPlanItems.Add(PlanItem);
end;
SetFocus;
end;
procedure TAwPlanGrid.TimeLineRowHeightsChanged(Sender: TObject);
var
iRow: Integer;
begin
with FTimeLine.TimeLineGrid do
for iRow := 0 to RowCount - 1 do
if RowHeights[iRow] <> DefaultRowHeight then
begin
SetDayHeight(RowHeights[iRow]);
Break;
end;
end;
end.
code D'essai:
with TAwPlanGrid.Create(Self) do
begin
SetBounds(10, 100, 600, 400);
Parent := Self;
Test;
end;
My 2 cts.
j'ai vu l'argument, et essayer de l'employer dans la pratique, que vous ne devriez jamais dessiner sur les mêmes pixels plus d'une fois.
Si vous dessinez un carré rouge sur un fond blanc puis vous peindre tout en blanc sauf lorsque le carré rouge , de "combler" le carré rouge:
il n'y a pas de clignotant, et vous faites moins d'opérations de dessin.
qui est un exemple extrême de invalider seulement ce que vous avez à , comme dthorp mentions . Si vous faites défiler un contrôle, utilisez ScrollWindow
pour que le sous-système graphique déplace ce qui est déjà là, et puis juste remplissez le bit manquant en bas.
il va y avoir des moments où vous ont pour peindre le même pixels plusieurs fois; le texte ClearType est le meilleur exemple. Le rendu ClearType nécessite l'accès aux pixels ci - dessous-ce qui signifie que vous allez à avoir pour remplir une zone avec du blanc, puis dessiner votre texte dessus.
mais même cela peut généralement être atténué en mesurant le rects
du texte que vous allez rendre, remplir clWhite
partout autrement , puis avoir DrawText
remplir zones de vide - à l'aide d'un blanc HBRUSH
contexte:
mais cette astuce ne peut pas fonctionner lorsque vous dessinez du texte sur un gradient, ou du contenu existant arbitraire - il y aura donc flicker. Dans ce cas, vous devez doubler le tampon d'une façon ou d'une autre. (Bien que ne doublez pas la mémoire tampon si l'utilisateur est dans une session distante - clignoter est mieux que le dessin lent).
Bavardage Bonus : maintenant que j'ai expliqué pourquoi vous ne devriez pas doubler le contenu de la mémoire tampon lorsque l'utilisateur tourne sur le bureau distant (C'est-à-dire les services de Terminal), vous savez maintenant ce que cette option avancée D'Internet Explorer signifie, ce qu'elle fait, et pourquoi elle est désactivée par défaut: