This is my first attempt at creating a component, I thought I would start with a very basic LED (light bulb not text), after reading a few articles I came up with the following code (which was working), I closed down the IDE (XE10.1 update2) and when trying to use the component in a new blank empty app the IDE crashes when adding the control can anybody help :
unit ZaxLED;
interface
uses
Windows, Messages, Controls, Forms, Graphics, ExtCtrls, Classes, math;
type
TZaxLED = class(TGraphicControl)
private
{ Private declarations }
FColorOn: Tcolor;
FColorOff: Tcolor;
Color: Tcolor;
FStatus: Boolean;
FOnChange: TNotifyEvent;
procedure SetColorOn(Value: Tcolor);
procedure SetColorOff(Value: Tcolor);
function GetStatus: Boolean;
procedure SetStatus(Value: Boolean);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
{ Published declarations }
property width default 17;
property height default 17;
property Align;
property Anchors;
property Constraints;
property ColorOn: Tcolor read FColorOn write SetColorOn default clLime;
property ColorOff: Tcolor read FColorOff write SetColorOff default clGray;
property Status: Boolean read GetStatus write SetStatus default True;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TZaxLED]);
end;
{ TZaxLED }
constructor TZaxLED.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
width := 17;
height := 17;
ColorOn := clLime;
ColorOff := clGray;
Status := False;
Color := ColorOff;
end;
destructor TZaxLED.Destroy;
begin
inherited Destroy;
end;
function TZaxLED.GetStatus: Boolean;
begin
Result := FStatus;
end;
procedure TZaxLED.Paint;
var
Radius, xCenter, YCenter: Integer;
begin
if csDesigning in ComponentState then
begin
Canvas.Pen.Style := psDot;
Canvas.Brush.Style := bsClear;
Canvas.Rectangle(ClientRect);
end;
Canvas.Brush.Color := Color;
Radius := Floor(width / 2) - 2;
xCenter := Floor(width / 2);
YCenter := Floor(height / 2);
Canvas.Ellipse(xCenter - Radius, YCenter - Radius, xCenter + Radius,
YCenter + Radius);
end;
procedure TZaxLED.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if Autosize and (Align in [alNone, alCustom]) then
inherited SetBounds(ALeft, ATop, width, height)
else
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
procedure TZaxLED.SetColorOff(Value: Tcolor);
begin
FColorOff := Value;
if not Status then
ColorOff := Value;
end;
procedure TZaxLED.SetColorOn(Value: Tcolor);
begin
FColorOn := Value;
if Status then
ColorOn := Value;
end;
procedure TZaxLED.SetStatus(Value: Boolean);
begin
if Value <> FStatus then
begin
FStatus := Value;
if FStatus then
Color := ColorOn
else
Color := ColorOff;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
end.
I have updated the code to take in comments from #Ari0nhh I think this is working but led is not changing color at design or runtime now
procedure TZaxLED.SetColorOff(Value: Tcolor);
begin
FColorOff := Value;
end;
procedure TZaxLED.SetColorOn(Value: Tcolor);
begin
FColorOn := Value;
end;
I see a number of problems with your code.
your uses clause needs cleanup. Do not create dependencies on units you do not actually use. Units that are only used by the component's internal code should be moved to the uses clause of the implementation section. The uses clause of the interface section should only refer to units that are needed to satisfy types/references directly used by your public interface.
a Color data member is being declared when there is already an inherited Color property. This data member is redundant and unnecessary, as its sole purpose is to carry the selected Status color from SetStatus() to Paint(), which is not necessary because Paint() can (and should) determine that color value directly.
the Status property is declared with a default value of True, but the property is initialized to False in the constructor.
the ColorOn and ColorOff property setters are calling themselves recursively, instead of triggering a repaint so the new state image can be shown.
The Status property setter is also not triggering a repaint.
With that said, try something more like this instead:
unit ZaxLED;
interface
uses
Classes, Controls, Graphics;
type
TZaxLED = class(TGraphicControl)
private
{ Private declarations }
FColorOn: TColor;
FColorOff: TColor;
FStatus: Boolean;
FOnChange: TNotifyEvent;
procedure SetColorOn(Value: TColor);
procedure SetColorOff(Value: TColor);
procedure SetStatus(Value: Boolean);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
{ Published declarations }
property Width default 17;
property Height default 17;
property Align;
property Anchors;
property Constraints;
property ColorOn: TColor read FColorOn write SetColorOn default clLime;
property ColorOff: TColor read FColorOff write SetColorOff default clGray;
property Status: Boolean read FStatus write SetStatus default False;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register;
implementation
uses
Math;
procedure Register;
begin
RegisterComponents('Samples', [TZaxLED]);
end;
{ TZaxLED }
constructor TZaxLED.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FColorOn := clLime;
FColorOff := clGray;
FStatus := False;
Width := 17;
Height := 17;
end;
procedure TZaxLED.Paint;
var
Radius, xCenter, YCenter: Integer;
begin
if csDesigning in ComponentState then
begin
Canvas.Pen.Style := psDot;
Canvas.Brush.Style := bsClear;
Canvas.Rectangle(ClientRect);
end;
if FStatus then
Canvas.Brush.Color := FColorOn
else
Canvas.Brush.Color := FColorOff;
Radius := Floor(Width / 2) - 2;
xCenter := Floor(Width / 2);
YCenter := Floor(Height / 2);
Canvas.Ellipse(xCenter - Radius, YCenter - Radius, xCenter + Radius, YCenter + Radius);
end;
procedure TZaxLED.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if AutoSize and (Align in [alNone, alCustom]) then
begin
AWidth := Width;
AHeight:= Height;
end;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
procedure TZaxLED.SetColorOff(Value: TColor);
begin
if FColorOff <> Value then
begin
FColorOff := Value;
if not FStatus then Invalidate;
end;
end;
procedure TZaxLED.SetColorOn(Value: TColor);
begin
if FColorOn <> Value then
begin
FColorOn := Value;
if FStatus then Invalidate;
end;
end;
procedure TZaxLED.SetStatus(Value: Boolean);
begin
if Value <> FStatus then
begin
FStatus := Value;
Invalidate;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
end.
Lets consider this code:
procedure TZaxLED.SetColorOff(Value: Tcolor);
begin
FColorOff := Value;
if not Status then
ColorOff := Value;
end;
An assignment of the property ColorOff will call a SetColorOff method. Which will again assign a ColorOff property. Since there is no way to break this assignment cycle, everything will end up with a stack overflow pretty fast.
Below is a transparent panel vcl
it works.
but I hope to draw solid border(other parts are still transparent)
Is there any hint?
Your comment welcome
unit aframek;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TAframekStyle = (
gsBlackness, gsDstInvert, gsMergeCopy, gsMergePaint, gsNotSrcCopy,
gsNotSrcErase, gsPatCopy, gsPatInvert, gsPatPaint, gsSrcAnd,
gsSrcCopy, gsSrcErase, gsSrcInvert, gsSrcPaint, gsWhiteness);
TAframek = class(TCustomControl)
private
FColor: TColor;
FStyle: TAframekStyle;
FOnPaint: TNotifyEvent;
procedure SetColor(Value: TColor);
procedure SetStyle(Value: TAframekStyle);
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
protected
Buffer: TBitmap;
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas;
published
property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property BorderWidth;
property Color: TColor read FColor write SetColor;
property Ctl3D;
property Enabled;
property Style: TAframekStyle read FStyle write SetStyle default gsSrcAnd;
property Visible;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('aka', [TAframek]);
end;
function AframekStyleToInt(gs: TAframekStyle): LongInt;
begin
case gs of
gsBlackness : Result := cmBlackness;
gsDstInvert : Result := cmDstInvert;
gsMergeCopy : Result := cmMergeCopy;
gsMergePaint : Result := cmMergePaint;
gsNotSrcCopy : Result := cmNotSrcCopy;
gsNotSrcErase: Result := cmNotSrcErase;
gsPatCopy : Result := cmPatCopy;
gsPatInvert : Result := cmPatInvert;
gsPatPaint : Result := cmPatPaint;
gsSrcAnd : Result := cmSrcAnd;
gsSrcCopy : Result := cmSrcCopy;
gsSrcErase : Result := cmSrcErase;
gsSrcInvert : Result := cmSrcInvert;
gsSrcPaint : Result := cmSrcPaint;
gsWhiteness : Result := cmWhiteness;
else Assert(True, 'Error parameter in function AframeStyleToInt');
end;
end;
constructor TAframek.Create(AOwner: TComponent);
var
FMarkBrush: LOGBRUSH;
FMarkPen: HPEN;
FPenStyle: array[0..1] of Integer;
FStartAngle: Single;
begin
inherited Create(AOwner);
Buffer := TBitmap.Create;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csDoubleClicks, csReplicatable];
Width := 100;
Height := 100;
FStyle := gsSrcAnd;
ParentCtl3d := False;
Ctl3D := False;
ParentColor := False;
FColor := clWhite;
end;
destructor TAframek.Destroy;
begin
Buffer.Free;
inherited Destroy;
end;
procedure TAframek.Paint;
var
R: TRect;
rop: LongInt;
begin
R := Rect(0, 0, Width, Height);
Buffer.Width := Width;
Buffer.Height := Height;
Buffer.Canvas.Brush.Style := bsSolid;
Buffer.Canvas.Brush.Color := FColor;
Buffer.Canvas.FillRect(Rect(0, 0, Width, Height));
rop := AframekStyleToInt(FStyle);
StretchBlt(Buffer.Canvas.Handle, 0, 0, Width, Height,
Canvas.Handle, 0, 0, Width, Height, rop);
if Ctl3D then DrawEdge(Buffer.Canvas.Handle, R, BDR_RAISEDINNER, BF_RECT);
Buffer.Canvas.Pen.Mode := pmCopy;
Buffer.Canvas.Pen.Style := psSolid;
Canvas.Draw(0, 0, Buffer);
if Assigned(FOnPaint) then FOnPaint(Self);
end;
procedure TAframek.SetColor(Value: TColor);
begin
if Value <> FColor then
begin
FColor := Value;
RecreateWnd;
end;
end;
procedure TAframek.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TAframek.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
Invalidate;
inherited;
end;
procedure TAframek.WMEraseBkgnd(var Message: TMessage);
begin
Message.Result := 0;
end;
procedure TAframek.Resize;
begin
Invalidate;
inherited;
end;
procedure TAframek.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
RecreateWnd;
end;
procedure TAframek.SetStyle(Value: TAframekStyle);
begin
if Value <> FStyle then
begin
FStyle := Value;
RecreateWnd;
end;
end;
end.
Looks like you did not draw the border excepting the case Ctrl3D property is True. But it gets False in constructor :)
If you want to draw the border in your own way, try to call TCanvas.Rectangle or TCanvas.FrameRect in Paint method after TCanvas.FillRect.
How can I change the border color of a GroupBox in Delphi?
Example source code from here:
(*
TEXSColoredGroupBox - Eddie Shipman
TGroupBox that allows colored and flat colored bevels.
Added three properties:
*******************************************************************************
property: - BevelShadowColor-
This is the color of the Bevel's Shadow, Default clBtnShadow.
Change this color to change the color of the Bevel's Shadow.
*******************************************************************************
property: BevelHighlightColor-
This is the color of the Bevel's Highlight, Default clBtnHighlight.
Change this color to change the color of the Bevel's Highlight.
*******************************************************************************
property: BevelWidth-
This is the width of the Bevel.
*******************************************************************************
This component will also draw the frame in "flat mode" if Ctl3D is False
using the BevelShadowColor.
It still has some problems with redrawing controls in design-time but it is
usable...
*******************************************************************************
*)
unit ColoredBorderGroupBox;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TEXSColoredGroupBox = class(TGroupBox)
private
{ private declarations }
FBevelLowColor: TColor;
FBevelHiColor : TColor;
FBevelWidth : Integer;
procedure SetBvlLowColor(Value: TColor);
procedure SetBvlHiColor(Value: TColor);
procedure SetBevelWidth(Value: Integer);
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure WMSize(var Message: TMessage); message WM_SIZE;
protected
{ protected declarations }
procedure CreateParams(Var Params:TCreateparams); override;
procedure Paint; override;
procedure SetParent(AParent:TWinControl); override;
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure DrawFrame(Rect:TRect);
procedure DrawFlatFrame(Rect:TRect);
procedure InvalidateFrame;
public
{ public declarations }
Constructor Create(AOwner:TComponent); override;
published
{ published declarations }
property BevelShadowColor :TColor read FBevelLowColor
write SetBvlLowColor;
property BevelHighlightColor:TColor read FBevelHiColor
write SetBvlHiColor;
property BevelWidth :Integer read FBevelWidth
write SetBevelWidth
default 1;
property Align;
property Caption;
property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnendDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('SST', [TEXSColoredGroupBox]);
end;
constructor TEXSColoredGroupBox.Create (AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csDoubleClicks, csReplicatable];
FBevelLowColor := clBtnShadow;
FBevelHiColor := clBtnHighlight;
FBevelWidth := 1;
end;
procedure TEXSColoredGroupBox.CreateParams(Var Params:TCreateparams);
begin
inherited CreateParams (Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TEXSColoredGroupBox.Paint;
var
H: Integer;
R: TRect;
begin
// No call to inherited needed.
// inherited Paint;
with Canvas do
begin
Font := Self.Font;
H := TextHeight('0');
R := Rect(0, H div 2 - 1, Width, Height);
if Ctl3D then
begin
DrawFrame(R);
end else
begin
Brush.Color := FBevelLowColor;
DrawFlatFrame(R);
end;
if Text <> '' then
begin
R := Rect(8, 0, 0, H);
Brush.Style := bsClear;
DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE
or
DT_CALCRECT);
// **********************
if not Enabled then
begin
OffsetRect(R, 1, 1);
Canvas.Font.Color := clBtnHighlight;
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or
DT_SINGLELINE);
OffsetRect(R, -1, -1);
Canvas.Font.Color := clBtnShadow;
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or
DT_SINGLELINE);
end
else
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or
DT_SINGLELINE);
// ****************************
// DrawText(Handle, PChar(Text), Length(Text), R, );
end;
end;
end;
procedure TEXSColoredGroupBox.AlignControls(AControl: TControl; var Rect:
TRect);
begin
Canvas.Font := Font;
Inc(Rect.Top, Canvas.TextHeight('0'));
InflateRect(Rect, -1, -1);
if Ctl3d then InflateRect(Rect, -1, -1);
inherited AlignControls(AControl, Rect);
end;
procedure TEXSColoredGroupBox.SetParent(AParent:TWinControl);
begin
inherited SetParent(AParent);
if Parent <> nil then
SetWindowLong(Parent.Handle, GWL_STYLE,
GetWindowLong(Parent.Handle, GWL_STYLE)
and not WS_ClipChildren);
end;
procedure TEXSColoredGroupBox.SetBvlLowColor(Value: TColor);
begin
if FBevelLowColor <> Value then
FBevelLowColor := Value;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.SetBvlHiColor(Value: TColor);
begin
if FBevelHiColor <> Value then
FBevelHiColor := Value;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.DrawFrame(Rect: TRect);
var
CaptionLength: Integer;
begin
with Canvas do
begin
Inc(Rect.Left, FBevelWidth); // 0,5 199,5
Inc(Rect.Top, FBevelWidth); //
Dec(Rect.Right, FBevelWidth); //
Dec(Rect.Bottom, FBevelWidth); // 0,198 198,198
CaptionLength := TextWidth(Text); //
Pen.Color := FBevelHiColor; //
Pen.Width := FBevelWidth; // 1,7 200,7
MoveTo(Rect.Left, Rect.Top); //
LineTo(6,Rect.Top); //
MoveTo(8+CaptionLength+2, Rect.Top); // 1,200 200,200
LineTo(Rect.Right,Rect.Top); //
LineTo(Rect.Right,Rect.Bottom);
LineTo(Rect.Left,Rect.Bottom);
LineTo(Rect.Left, Rect.Top);
Pen.Color := FBevelLowColor;
Pen.Width := FBevelWidth;
OffsetRect(Rect, -FBevelWidth, -FBevelWidth);
MoveTo(Rect.Left, Rect.Top);
LineTo(6,Rect.Top);
MoveTo(8+CaptionLength+2, Rect.Top);
LineTo(Rect.Right,Rect.Top);
LineTo(Rect.Right,Rect.Bottom);
LineTo(Rect.Left,Rect.Bottom);
LineTo(Rect.Left, Rect.Top);
end;
end;
procedure TEXSColoredGroupBox.DrawFlatFrame(Rect: TRect);
var
CaptionLength: Integer;
begin
with Canvas do
begin
Dec(Rect.Right);
Dec(Rect.Bottom);
CaptionLength := TextWidth(Text);
Pen.Color := FBevelLowColor;
Pen.Width := FBevelWidth;
MoveTo(Rect.Left, Rect.Top);
LineTo(6,Rect.Top);
MoveTo(8+CaptionLength+2, Rect.Top);
LineTo(Rect.Right,Rect.Top);
LineTo(Rect.Right,Rect.Bottom);
LineTo(Rect.Left,Rect.Bottom);
LineTo(Rect.Left, Rect.Top);
end;
end;
procedure TEXSColoredGroupBox.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and CanFocus then
begin
SelectFirst;
Result := 1;
end else
inherited;
end;
procedure TEXSColoredGroupBox.CMTextChanged(var Message: TMessage);
begin
inherited;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.WMSize(var Message: TMessage);
begin
if (csDesigning in ComponentState) then
InvalidateFrame;
inherited;
end;
procedure TEXSColoredGroupBox.InvalidateFrame;
var
R: TRect;
begin
R := BoundsRect;
InflateRect(R, 1, 1);
If (Parent <> Nil) and Parent.HandleAllocated then
InvalidateRect(Parent.Handle, #R, True)
Else
inherited Invalidate;
end;
procedure TEXSColoredGroupBox.SetBevelWidth(Value:Integer);
begin
if Value <> FBevelWidth then
FBevelWidth := Value;
Repaint;
end;
end.
I am looking for a line component.
I have seen a couple examples, however they dont enable
the line to be drawn at any angle, or
with different line paterns - dot/dash
etc.
I would like to be able to do something similar to the INSERT/SHAPES/LINE in MS word, that i can grab the anchor at an end and drag at any angle...
This is one i found: TLine v.1.0
but it only lets me draw horizontal or vertical lines, not a line at say 17 degrees..
This link is the type of thing i want to do, have anchor points at the end of the line, so i can click on them at runtime and drag the line
Does anyone know of a component (freeware) that
can do what i want or
help to convert the above to do what i want, or
any suggests that might help..
thanks in advance...
I understand you have found a component, but it is missing some properties you wish for. Well, I took a look at how TShape is made and came up with the following try out:
Update:
Properties AutoAngle and Backwards added.
unit Line;
interface
uses
Windows, Classes, Controls, Graphics, StdCtrls, Math;
type
TLine = class(TGraphicControl)
private
FAlignment: TAlignment;
FAngle: Integer;
FAutoAngle: Boolean;
FLayout: TTextLayout;
FPen: TPen;
function DiagonalAngle: Integer;
function GetBackwards: Boolean;
function GetExtends(LimitWidth, LimitHeight: Integer): TRect;
procedure PenChanged(Sender: TObject);
procedure SetAlignment(Value: TAlignment);
procedure SetAngle(Value: Integer);
procedure SetAutoAngle(Value: Boolean);
procedure SetBackwards(Value: Boolean);
procedure SetLayout(Value: TTextLayout);
procedure SetPen(Value: TPen);
protected
procedure AdjustSize; override;
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Align;
property Alignment: TAlignment read FAlignment write SetAlignment
default taCenter;
property Anchors;
property Angle: Integer read FAngle write SetAngle;
property AutoAngle: Boolean read FAutoAngle write SetAutoAngle
default True;
property AutoSize;
property Backwards: Boolean read GetBackwards write SetBackwards
stored False;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Layout: TTextLayout read FLayout write SetLayout default tlCenter;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property ParentShowHint;
property Pen: TPen read FPen write SetPen;
property ShowHint;
property Visible;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TLine]);
end;
{ TLine }
procedure TLine.AdjustSize;
begin
if AutoSize then
FAutoAngle := False;
inherited AdjustSize;
end;
function TLine.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
with GetExtends(NewWidth, NewHeight) do
begin
NewWidth := Right;
NewHeight := Bottom;
end;
Result := True;
end;
constructor TLine.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
Width := 65;
Height := 65;
FPen := TPen.Create;
FPen.OnChange := PenChanged;
FAlignment := taCenter;
FLayout := tlCenter;
FAutoAngle := True;
end;
destructor TLine.Destroy;
begin
FPen.Free;
inherited Destroy;
end;
function TLine.DiagonalAngle: Integer;
begin
if Width = FPen.Width then
Result := 90
else if Height = FPen.Width then
Result := 0
else
if Backwards then
Result := 180 - Round(RadToDeg(ArcTan(Height / Width)))
else
Result := Round(RadToDeg(ArcTan(Height / Width)));
end;
function TLine.GetBackwards: Boolean;
begin
Result := FAngle > 90;
end;
function TLine.GetExtends(LimitWidth, LimitHeight: Integer): TRect;
begin
Result.Left := 0;
Result.Top := 0;
if FAngle = 0 then
begin
Result.Right := LimitWidth;
Result.Bottom := FPen.Width;
end
else if FAngle = 90 then
begin
Result.Right := FPen.Width;
Result.Bottom := LimitHeight;
end
else
begin
Result.Right := Min(LimitWidth,
Round(LimitHeight / Abs(Tan(DegToRad(FAngle)))));
Result.Bottom := Min(LimitHeight,
Round(LimitWidth * Abs(Tan(DegToRad(FAngle)))));
end;
end;
procedure TLine.Paint;
var
R: TRect;
begin
Canvas.Pen.Assign(FPen);
Canvas.Brush.Style := bsClear;
R := GetExtends(Width, Height);
case FAlignment of
taCenter:
OffsetRect(R, (Width - R.Right) div 2, 0);
taRightJustify:
OffsetRect(R, Width - R.Right, 0);
end;
case FLayout of
tlCenter:
OffsetRect(R, 0, (Height - R.Bottom) div 2);
tlBottom:
OffsetRect(R, 0, Height - R.Bottom);
end;
if FAngle = 0 then
begin
Canvas.MoveTo(R.Left, R.Top + FPen.Width div 2);
Canvas.LineTo(R.Right, R.Top + FPen.Width div 2);
end
else if FAngle = 90 then
begin
Canvas.MoveTo(R.Left + FPen.Width div 2, R.Top);
Canvas.LineTo(R.Left + FPen.Width div 2, R.Bottom);
end
else if FAngle < 90 then
begin
Canvas.MoveTo(R.Left, R.Bottom);
Canvas.LineTo(R.Right, R.Top);
end
else
begin
Canvas.MoveTo(R.Left, R.Top);
Canvas.LineTo(R.Right, R.Bottom);
end;
end;
procedure TLine.PenChanged(Sender: TObject);
begin
AdjustSize;
Invalidate;
end;
procedure TLine.Resize;
begin
if FAutoAngle then
Angle := DiagonalAngle;
inherited Resize;
end;
procedure TLine.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
Invalidate;
end;
end;
procedure TLine.SetAngle(Value: Integer);
begin
while Value < 0 do
Inc(Value, 180);
while Value >= 180 do
Dec(Value, 180);
if FAngle <> Value then
begin
FAngle := Value;
if FAngle <> DiagonalAngle then
FAutoAngle := False;
if AutoSize then
AdjustSize;
Invalidate;
end;
end;
procedure TLine.SetAutoAngle(Value: Boolean);
begin
if FAutoAngle <> Value then
begin
FAutoAngle := Value;
if FAutoAngle then
begin
AutoSize := False;
Angle := DiagonalAngle;
end;
end;
end;
procedure TLine.SetBackwards(Value: Boolean);
begin
if Backwards <> Value then
Angle := 180 - FAngle;
end;
procedure TLine.SetLayout(Value: TTextLayout);
begin
if FLayout <> Value then
begin
FLayout := Value;
Invalidate;
end;
end;
procedure TLine.SetPen(Value: TPen);
begin
FPen.Assign(Value);
end;
end.
EFG's Computer Lab Graphic Line Stretch comes close to what you are looking for.
Look and feel:
(source: efg2.com)
I thought I could just throw this out there and just ask: I have seen Delphi controls that are flawless in terms of graphical effects. Meaning: no flickering, sectioned updates (only redraw the section of a control that is marked as dirty) and smooth scrolling.
I have coded a lot of graphical controls over the years, so I know about double buffering, dibs, bitblts and all the "common" stuff (I always use dibs to draw everything if possible, but there is an overhead). Also know about InvalidateRect and checking TCanvas.ClipRect for the actual rect that needs to be updated. Despite all these typical solutions, I find it very difficult to create the same quality components as say - Developer Express or Razed Components. If the graphics is smooth you can bet the scrollbars (native) flicker, and if the scrollbars and frame is smooth you can swear the background flickers during scrolling.
Is there a standard setup of code to handle this? A sort of best practises that ensures smooth redraws of the entire control -- including the non-client area of a control?
For instance, here is a "bare bone" control which take height for segmented updates (only redraw what is needed). If you create it on a form, try moving a window over it, and watch it replace the parts with colors (see paint method).
Does anyone have a similar base class that can handle non client area redraws without flickering?
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;
Updated
I just wanted to add that what did the trick was a combination of:
ExcludeClipRect() when drawing the non-clientarea, so you dont overlap with the graphics in the clientarea
Catching the WMNCCalcSize message rather than just using the bordersize for measurements. I also had to take height for the edge sizes:
XEdge := GetSystemMetrics(SM_CXEDGE);
YEdge := GetSystemMetrics(SM_CYEDGE);
Calling RedrawWindow() with the following flags whenever you have scrollbars that have moved or a resize:
mRect:=ClientRect;
mFlags:=rdw_Invalidate
or RDW_NOERASE
or RDW_FRAME
or RDW_INTERNALPAINT
or RDW_NOCHILDREN;
RedrawWindow(windowhandle,#mRect,0,mFlags);
When updating the background during the Paint() method, avoid drawing over possible child objects, like this (see the RDW_NOCHILDREN mentioned above):
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;
Thanks for the help guys!
Double buffering and fancy drawing tactics are only half the story. The other half, some would argue the more critical half, is to limit how much of your control is invalidated.
In your comments, you mention that you use RedrawWindow(handle, #R, 0, rdw_Invalidate or rdw_Frame). What are you setting the R rectangle to? If you set it to your client area rect, then you are redrawing the entire client area of your control. When scrolling, only a small portion of your control needs to be redrawn - the slice at the "trailing edge" of the scroll direction. Windows will bitblit the rest of the client area screen to screen to move the existing pixels over in the scroll direction.
Also check whether you have set your window flags to require full redraw on scroll. I don't recall the flag names offhand, but you want them turned off so that scroll actions only invalidate a slice of your client area. I believe this is the Windows default.
Even with hardware accelerated graphics, less work is faster than more work. Get your invalidate rects down to the absolute minimum and reduce the number of pixels you're pushing across the system bus.
For instance, here is a "bare bone" control which take height for segmented updates (only redraw what is needed). If you create it on a form, try moving a window over it, and watch it replace the parts with colors (see paint method).
Does anyone have a similar base class that can handle non client area redraws without flickering?
Well, your TMyControl does not have a non client area (yet). So I added BorderWidth := 10; and now it has. ;)
In general, the non client area's of default Windows windows are automatically painted without flickering, including scrollbars, titles, etc... (at least, I have not witnessed otherwise).
If you want to paint your own border, you have to handle WM_NCPAINT. See this 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.
A few remarks:
Override CreateParams instead of declaring it virtual. Mind the compiler warning (though I think/hope this is a little mistake).
You don't have to check for isEmptyRect nor isSameRect. If ClipRect is empty, then there is nothing to draw. This is also the reason why never to call Paint directly, but always through Invalidate or equivalent.
AdjustClientRect is not needed. It is called internally when needed for its purpose.
And as a bonus, this is exactly how I draw a chessbord component:
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;
That is quite an open question. Much tips and answers have already been given. I would like to add two:
Include csOpaque in ControlStyle if you paint ClientRect fully,
Exclude CS_HREDRAW and CS_VREDRAW from Params.WindowClass.Style in CreateParams.
Since you are especially interested in drawing on TScrollingWinControl, I spend the last couple of hours on reducing the code of a planning component of mine, to get only the necessary painting and scrolling code. It is just an example and by no means fully functional or meant as holy, but it might provide some 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 = $0099A8AC;
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.
Testing code:
with TAwPlanGrid.Create(Self) do
begin
SetBounds(10, 100, 600, 400);
Parent := Self;
Test;
end;
My 2 cts.
i have seen the argument, and try to employ it in practice, that you should never draw over the same pixels more than once.
If you're drawing a red square on a white background then you paint everything white except where the red square will go, then you "fill in" the red square:
There's no flicker, and you're doing fewer drawing operations.
That is an extreme example of only invalidate what you have to, as dthorp mentions. If you're scrolling a control, use ScrollWindow to have the graphics subsystem move what's already there, and then just fill in the missing bit at the bottom.
There are going to be times where you have to paint the same pixels multiple times; ClearType text is the best example. ClearType rendering requires access to the pixels underneath - which means you're going to have to fill an area with white, then draw your text over it.
But even that can usually be mitigated by measuring the rects of the text you're going to render, fill clWhite everywhere else, then have DrawText fill in the empty areas - using a white HBRUSH background:
But that trick cannot work when drawing text on a gradient, or arbitrary existing content - so there will be flicker. In that case you have to double buffer in some way. (Although don't double buffer if the user is in a remote session - flickering is better than slow drawing).
Bonus Chatter: Now that i've explained why you shouldn't double buffer content when the user is running though Remote Desktop (i.e. Terminal Services), you now know what this Internet Explorer advanced option means, what it does, and why it is off by default: