I'm building a custom control which consists of a list of items which are positioned either horizontally or vertically (extra stretching/fitting for each item). While things do appear to work fine, I have one problem where rapid mouse movement (or otherwise rapid painting) causes it to flicker. I am using an intermittent Bitmap for all my drawing, and copying it over to the main control canvas when necessary (using BitBlt). I'm afraid the code is too large and complex to write a simplified sample of my problem, especially since the complexity is probably what's causing it to flicker.
Can someone take a look at my control and let me know how to prevent this flicker? If I enabled "DoubleBuffered" it shows fine with no flicker, but I shouldn't have to do this. Even on good performing computers it flickers, and I'm scared to see how it flickers on a poor computer.
Just create a new instance of this control and add 5 or 6 items via the "Items" property. Then, in run-time, quickly move the mouse back and forth over all the items in this control. It flashes white periodically.
PS - This control is not completely done, but is workable. You will find some unimplemented things such as the Image List.
JD Solutions
Can someone take a look at my control and let me know how to prevent this flicker? If I enabled "DoubleBuffered" it shows fine with no flicker, but I shouldn't have to do this. Even on good performing computers it flickers, and I'm scared to see how it flickers on a poor computer.
Just create a new instance of this control and add 5 or 6 items via the "Items" property. Then, in run-time, quickly move the mouse back and forth over all the items in this control. It flashes white periodically.
PS - This control is not completely done, but is workable. You will find some unimplemented things such as the Image List.
Code:
unit JD.Breadcrumb;
interface
uses
Winapi.Windows, Winapi.Messages,
System.Classes, System.SysUtils,
Vcl.Graphics, Vcl.Controls, Vcl.ImgList;
type
TJDBreadcrumb = class;
TJDCustomBreadcrumb = class;
TJDBreadcrumbItem = class;
TJDBreadcrumbItems = class;
TJDBreadcrumbItemStyle = class;
TPoints = array of TPoint;
//General style of breadcrumb items
TJDBreadcrumbStyle = (bsArrows, bsItemIcons, bsStateIcons, bsText);
//How to display icon images in breadcrumb items
TJDBreadcrumbIcons = (biNone, biCenter, biLeft, biRight, biTop, biBottom);
//Direction or Orientation of breadcrumb list
TBreadcrumbDir = (bdHorizontal, bdVertical);
//How to size each breadcrumb item
TBreadcrumbSize = (bsManual, bsAuto, bsStretch);
//Current state of a breadcrumb item
TBreadcrumbState = (stPending, stSelected, stPassed, stDisabled);
TBreadcrumbItemEvent = procedure(Sender: TObject; var Item: TJDBreadcrumbItem) of object;
TBreadcrumbItemSelectEvent = procedure(Sender: TObject;
var Item: TJDBreadcrumbItem; var Accept: Bool) of object;
TBreadcrumbItemMouseEvent = procedure(Sender: TObject; var Item: TJDBreadcrumbItem;
const Button: TMouseButton; const Shift: TShiftState; const X, Y: Integer) of object;
TJDBreadcrumbItemStyle = class(TPersistent)
private
FColor: TColor;
FCaptionFont: TFont;
FSubCaptionFont: TFont;
FOnChange: TNotifyEvent;
FBorderColor: TColor;
FBorderWidth: Integer;
procedure FontChanged(Sender: TObject);
procedure SetColor(const Value: TColor);
procedure SetCaptionFont(const Value: TFont);
procedure SetSubCaptionFont(const Value: TFont);
procedure SetBorderColor(const Value: TColor);
procedure SetBorderWidth(const Value: Integer);
public
constructor Create;
destructor Destroy; override;
procedure Changed;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
published
property Color: TColor read FColor write SetColor;
property CaptionFont: TFont read FCaptionFont write SetCaptionFont;
property SubCaptionFont: TFont read FSubCaptionFont write SetSubCaptionFont;
property BorderWidth: Integer read FBorderWidth write SetBorderWidth;
property BorderColor: TColor read FBorderColor write SetBorderColor;
end;
TJDBreadcrumbItem = class(TCollectionItem)
private
FSubCaption: TCaption;
FCaption: TCaption;
FLength: Integer;
FEnabled: Boolean;
FIndex: Integer;
function GetOwner: TJDBreadcrumb;
function GetLength: Integer;
function GetCaptionRect: TRect;
function GetItemRect: TRect;
procedure SetCaption(const Value: TCaption);
procedure SetSubCaption(const Value: TCaption);
procedure SetLength(const Value: Integer);
procedure SetEnabled(const Value: Boolean);
function GetItemState: TBreadcrumbState;
function GetColor: TColor;
function GetFont: TFont;
function GetPoints: TPoints;
function GetBorderColor: TColor;
function GetBorderWidth: Integer;
public
constructor Create(AOwner: TCollection); override;
destructor Destroy; override;
procedure Invalidate;
property Breadcrumb: TJDBreadcrumb read GetOwner;
property ItemState: TBreadcrumbState read GetItemState;
property Index: Integer read FIndex;
property Font: TFont read GetFont;
property Color: TColor read GetColor;
property CaptionRect: TRect read GetCaptionRect;
property ItemRect: TRect read GetItemRect;
property Points: TPoints read GetPoints;
property BorderWidth: Integer read GetBorderWidth;
property BorderColor: TColor read GetBorderColor;
published
property Caption: TCaption read FCaption write SetCaption;
property SubCaption: TCaption read FSubCaption write SetSubCaption;
property Length: Integer read GetLength write SetLength;
property Enabled: Boolean read FEnabled write SetEnabled;
end;
TJDBreadcrumbItems = class(TOwnedCollection)
private
function GetItem(Index: Integer): TJDBreadcrumbItem;
procedure SetItem(Index: Integer; const Value: TJDBreadcrumbItem);
public
constructor Create(AOwner: TComponent); reintroduce;
destructor Destroy; override;
function Add: TJDBreadcrumbItem;
procedure Delete(const Index: Integer);
procedure Invalidate;
property Items[Index: Integer]: TJDBreadcrumbItem read GetItem write SetItem; default;
published
end;
TJDCustomBreadcrumb = class(TCustomControl)
private
FDrawing: Bool;
FBitmap: TBitmap;
FItems: TJDBreadcrumbItems;
FDirection: TBreadcrumbDir;
FItemIndex: Integer;
FMouseIndex: Integer;
FMouseDownIndex: Integer;
FMouseDownPos: TPoint;
FKeyState: TKeyboardState;
FShift: TShiftState;
FStylePending: TJDBreadcrumbItemStyle;
FStylePassed: TJDBreadcrumbItemStyle;
FStyleDisabled: TJDBreadcrumbItemStyle;
FStyleSelected: TJDBreadcrumbItemStyle;
FStyle: TJDBreadcrumbStyle;
FShowDisabled: Boolean;
FShowSubCaptions: Boolean;
FGap: Integer;
FIconStyle: TJDBreadcrumbIcons;
FSizing: TBreadcrumbSize;
FIndent: Integer;
FMargin: Integer;
FImages: TImageList;
FOnItemMouseDown: TBreadcrumbItemMouseEvent;
FOnItemMouseUp: TBreadcrumbItemMouseEvent;
FOnSelectItem: TBreadcrumbItemSelectEvent;
procedure GetShiftState;
function DoSelectItem: Bool;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMSysKeyDown(var Message: TWMSysKeyDown); message WM_SYSKEYDOWN;
procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
procedure WMSysKeyUp(var Message: TWMSysKeyUp); message WM_SYSKEYUP;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;
procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
procedure Changed(Sender: TObject);
procedure SetItems(const Value: TJDBreadcrumbItems);
procedure SetDirection(const Value: TBreadcrumbDir);
procedure SetColor(const Value: TColor);
procedure SetItemIndex(const Value: Integer);
procedure SetStyleDisabled(const Value: TJDBreadcrumbItemStyle);
procedure SetStylePassed(const Value: TJDBreadcrumbItemStyle);
procedure SetStylePending(const Value: TJDBreadcrumbItemStyle);
procedure SetStyleSelected(const Value: TJDBreadcrumbItemStyle);
procedure SetStyle(const Value: TJDBreadcrumbStyle);
procedure SetShowDisabled(const Value: Boolean);
procedure SetShowSubCaptions(const Value: Boolean);
procedure SetGap(const Value: Integer);
procedure SetIconStyle(const Value: TJDBreadcrumbIcons);
procedure SetSizing(const Value: TBreadcrumbSize);
procedure SetIndent(const Value: Integer);
procedure SetMargin(const Value: Integer);
function GetColor: TColor;
procedure SetImages(const Value: TImageList);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function HasImages: Boolean;
property Style: TJDBreadcrumbStyle read FStyle write SetStyle;
property Items: TJDBreadcrumbItems read FItems write SetItems;
property Direction: TBreadcrumbDir read FDirection write SetDirection default bdHorizontal;
property ItemIndex: Integer read FItemIndex write SetItemIndex;
property IconStyle: TJDBreadcrumbIcons read FIconStyle write SetIconStyle;
property Sizing: TBreadcrumbSize read FSizing write SetSizing;
property Margin: Integer read FMargin write SetMargin;
property Gap: Integer read FGap write SetGap;
property Color: TColor read GetColor write SetColor;
property Indent: Integer read FIndent write SetIndent;
property StylePending: TJDBreadcrumbItemStyle read FStylePending write SetStylePending;
property StyleSelected: TJDBreadcrumbItemStyle read FStyleSelected write SetStyleSelected;
property StylePassed: TJDBreadcrumbItemStyle read FStylePassed write SetStylePassed;
property StyleDisabled: TJDBreadcrumbItemStyle read FStyleDisabled write SetStyleDisabled;
property ShowDisabled: Boolean read FShowDisabled write SetShowDisabled;
property ShowSubCaptions: Boolean read FShowSubCaptions write SetShowSubCaptions;
property Images: TImageList read FImages write SetImages;
property MouseIndex: Integer read FMouseIndex;
property OnItemMouseDown: TBreadcrumbItemMouseEvent
read FOnItemMouseDown write FOnItemMouseDown;
property OnItemMouseUp: TBreadcrumbItemMouseEvent
read FOnItemMouseUp write FOnItemMouseUp;
property OnSelectItem: TBreadcrumbItemSelectEvent
read FOnSelectItem write FOnSelectItem;
end;
TJDBreadcrumb = class(TJDCustomBreadcrumb)
published
property Items;
property IconStyle default biNone;
property Sizing default bsStretch;
property ItemIndex;
property Indent;
property Margin;
property Gap;
property Direction default bdHorizontal;
property Color;
property StylePending;
property StyleSelected;
property StylePassed;
property StyleDisabled;
property Style default bsArrows;
property ShowDisabled default True;
property ShowSubCaptions default False;
property Images;
property Align;
property Anchors;
property DoubleBuffered default False;
property ParentColor;
property Height;
property Width;
property OnItemMouseDown;
property OnItemMouseUp;
property OnSelectItem;
end;
implementation
function PolyRect(const Points: TPoints): TRect;
var
X: Integer;
P: TPoint;
begin
if Length(Points) > 0 then begin
Result:= Rect(MAXINT, MAXINT, 0, 0);
for X := 0 to Length(Points) - 1 do begin
P:= Points[X];
if P.X < Result.Left then
Result.Left:= P.X;
if P.X > Result.Right then
Result.Right:= P.X;
if P.Y < Result.Top then
Result.Top:= P.Y;
if P.Y > Result.Bottom then
Result.Bottom:= P.Y;
end;
end else begin
Result:= Rect(0, 0, 0, 0);
end;
end;
{ TJDCustomBreadcrumb }
constructor TJDCustomBreadcrumb.Create(AOwner: TComponent);
begin
inherited;
ControlStyle:= ControlStyle - [csDesignInteractive] + [csCaptureMouse];
FBitmap:= TBitmap.Create;
FItems:= TJDBreadcrumbItems.Create(Self);
FImages:= nil;
FDrawing:= False;
FStylePending:= TJDBreadcrumbItemStyle.Create;
FStylePending.OnChange:= Changed;
FStylePending.Color:= clWhite;
FStylePending.CaptionFont.Style:= [fsBold];
FStylePending.CaptionFont.Size:= 14;
FStyleSelected:= TJDBreadcrumbItemStyle.Create;
FStyleSelected.OnChange:= Changed;
FStyleSelected.Color:= clBlue;
FStyleSelected.CaptionFont.Style:= [fsBold];
FStyleSelected.CaptionFont.Size:= 14;
FStyleSelected.CaptionFont.Color:= clWhite;
FStylePassed:= TJDBreadcrumbItemStyle.Create;
FStylePassed.OnChange:= Changed;
FStylePassed.Color:= clSkyBlue;
FStylePassed.CaptionFont.Style:= [fsBold];
FStylePassed.CaptionFont.Size:= 14;
FStyleDisabled:= TJDBreadcrumbItemStyle.Create;
FStyleDisabled.OnChange:= Changed;
FStyleDisabled.Color:= clGray;
FStyleDisabled.CaptionFont.Style:= [fsBold];
FStyleDisabled.CaptionFont.Size:= 14;
Width:= 300;
Height:= 75;
FMouseIndex:= -1;
inherited Color:= clBtnFace;
FShowDisabled:= True;
FShowSubCaptions:= False;
FSizing:= bsStretch;
FIconStyle:= biNone;
FGap:= 6;
FIndent:= 20;
Invalidate;
end;
destructor TJDCustomBreadcrumb.Destroy;
begin
FStylePending.Free;
FStyleSelected.Free;
FStylePassed.Free;
FStyleDisabled.Free;
FItems.Free;
FBitmap.Free;
inherited;
end;
function TJDCustomBreadcrumb.DoSelectItem: Bool;
var
A: Bool;
I: TJDBreadcrumbItem;
begin
Result:= True;
A:= True;
if (FMouseDownIndex >= 0) and (FMouseDownIndex < FItems.Count) then begin
I:= FItems[FMouseDownIndex];
if assigned(FOnSelectItem) then begin
FOnSelectItem(Self, I, A);
Result:= A;
end;
if A then begin
FItemIndex:= FMouseDownIndex;
Invalidate;
end;
end else begin
Result:= False;
end;
end;
function TJDCustomBreadcrumb.GetColor: TColor;
begin
Result:= inherited Color;
end;
function TJDCustomBreadcrumb.HasImages: Boolean;
begin
Result:= Assigned(FImages);
end;
procedure TJDCustomBreadcrumb.Paint;
var
X: Integer;
I: TJDBreadcrumbItem;
Dst: Integer;
Wid: Integer;
Coords: TPoints;
H: Integer;
Col: TColor;
R: TRect;
Can: TCanvas;
begin
//if not FDrawing then begin
//FDrawing:= True;
//try
if FBitmap.Width <> ClientWidth then
FBitmap.Width:= ClientWidth;
if FBitmap.Height <> ClientHeight then
FBitmap.Height:= ClientHeight;
Can:= FBitmap.Canvas;
Can.Brush.Style:= bsSolid;
Can.Pen.Style:= psClear;
Can.Brush.Color:= Color;
Can.FillRect(Can.ClipRect);
Dst:= FMargin;
case FDirection of
bdHorizontal: begin
Wid:= ClientHeight - (FMargin * 2);
end;
bdVertical: begin
Wid:= ClientWidth - (FMargin * 2);
end;
end;
H:= Wid div 2;
for X := 0 to Items.Count - 1 do begin
I:= Items[X];
I.FIndex:= X;
if ((I.Enabled = False) and (FShowDisabled)) or (I.Enabled) then begin
Col:= I.Color;
Can.Pen.Style:= psClear;
Can.Brush.Style:= bsSolid;
Can.Brush.Color:= Col;
Can.Font.Assign(I.Font);
Coords:= I.Points;
R:= I.ItemRect;
Dst:= Dst + I.Length - FIndent + FGap;
Can.Polygon(Coords);
Can.Brush.Style:= bsClear;
if FMouseIndex < 0 then begin //Mouse is not over anything
if I.BorderWidth > 0 then begin
Can.Pen.Style:= psSolid;
Can.Pen.Color:= I.BorderColor;
Can.Pen.Width:= I.BorderWidth;
Can.Polygon(Coords);
end;
end else begin //Mouse is over something
if FMouseIndex = X then begin //Mouse is over this item
Can.Pen.Style:= psSolid;
Can.Pen.Color:= clBlack;
Can.Pen.Width:= 2;
Can.Polygon(Coords);
end else begin //Mouse is NOT over this item
if I.BorderWidth > 0 then begin
Can.Pen.Style:= psSolid;
Can.Pen.Color:= I.BorderColor;
Can.Pen.Width:= I.BorderWidth;
Can.Polygon(Coords);
end;
end;
end;
InflateRect(R, -FIndent, -FMargin);
DrawText(Can.Handle, PChar(I.Caption), Length(I.Caption),
R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
end;
BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
//finally
//FDrawing:= False;
//end;
//end;
end;
procedure TJDCustomBreadcrumb.Changed(Sender: TObject);
begin
Invalidate;
end;
procedure TJDCustomBreadcrumb.SetColor(const Value: TColor);
begin
if Value <> Color then begin
inherited Color := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetDirection(const Value: TBreadcrumbDir);
begin
if Value <> FDirection then begin
FDirection := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetGap(const Value: Integer);
begin
if Value <> FGap then begin
FGap := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetIconStyle(const Value: TJDBreadcrumbIcons);
begin
if Value <> FIconStyle then begin
FIconStyle := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetImages(const Value: TImageList);
begin
FImages:= Value;
Invalidate;
end;
procedure TJDCustomBreadcrumb.SetIndent(const Value: Integer);
begin
if Value <> FIndent then begin
FIndent := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetItemIndex(const Value: Integer);
begin
if Value <> FItemIndex then begin
FItemIndex := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetItems(const Value: TJDBreadcrumbItems);
begin
FItems.Assign(Value);
Invalidate;
end;
procedure TJDCustomBreadcrumb.SetMargin(const Value: Integer);
begin
if Value <> FMargin then begin
FMargin := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetShowDisabled(const Value: Boolean);
begin
if Value <> FShowDisabled then begin
FShowDisabled := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetShowSubCaptions(const Value: Boolean);
begin
if Value <> FShowSubCaptions then begin
FShowSubCaptions := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetSizing(const Value: TBreadcrumbSize);
begin
if Value <> FSizing then begin
FSizing := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetStyle(const Value: TJDBreadcrumbStyle);
begin
if Value <> FStyle then begin
FStyle := Value;
Invalidate;
end;
end;
procedure TJDCustomBreadcrumb.SetStyleDisabled(
const Value: TJDBreadcrumbItemStyle);
begin
FStyleDisabled.Assign(Value);
Invalidate;
end;
procedure TJDCustomBreadcrumb.SetStylePassed(
const Value: TJDBreadcrumbItemStyle);
begin
FStylePassed.Assign(Value);
Invalidate;
end;
procedure TJDCustomBreadcrumb.SetStylePending(
const Value: TJDBreadcrumbItemStyle);
begin
FStylePending.Assign(Value);
Invalidate;
end;
procedure TJDCustomBreadcrumb.SetStyleSelected(
const Value: TJDBreadcrumbItemStyle);
begin
FStyleSelected.Assign(Value);
Invalidate;
end;
function PointInPolygon(Point: TPoint; const Polygon: array of TPoint): Boolean;
var
rgn: HRGN;
begin
rgn := CreatePolygonRgn(Polygon[0], Length(Polygon), WINDING);
Result := PtInRegion(rgn, Point.X, Point.Y);
DeleteObject(rgn);
end;
procedure TJDCustomBreadcrumb.CMMouseEnter(var Msg: TMessage);
begin
Invalidate;
inherited;
end;
procedure TJDCustomBreadcrumb.CMMouseLeave(var Msg: TMessage);
begin
FMouseIndex:= -1;
Invalidate;
inherited;
end;
procedure TJDCustomBreadcrumb.WMNCHitTest(var Message: TWMNCHitTest);
var
P: TPoint;
Poly: TPoints;
X: Integer;
I: TJDBreadcrumbItem;
OldIndex: Integer;
begin
if csDesigning in ComponentState then
Message.Result := HTCLIENT
else begin
P.X:= Message.Pos.X;
P.Y:= Message.Pos.Y;
P:= ScreenToClient(P);
OldIndex:= FMouseIndex;
FMouseIndex:= -1;
for X := 0 to Items.Count - 1 do begin
I:= Items[X];
Poly:= I.Points;
if PointInPolygon(P, Poly) then begin
FMouseIndex:= X;
Break;
end;
end;
if FMouseIndex <> OldIndex then Invalidate;
end;
inherited;
end;
procedure TJDCustomBreadcrumb.GetShiftState;
var
S: TShiftState;
begin
GetKeyboardState(FKeyState);
S:= [];
if (FKeyState[vk_Shift] and 128) <> 0 then
FShift:= FShift + [ssShift];
if (FKeyState[vk_Control] and 128) <> 0 then
FShift:= FShift + [ssCtrl];
if (FKeyState[vk_Menu] and 128) <> 0 then
FShift:= FShift + [ssAlt];
if (FKeyState[VK_LBUTTON] and 128) <> 0 then
FShift:= FShift + [ssLeft];
if (FKeyState[VK_MBUTTON] and 128) <> 0 then
FShift:= FShift + [ssMiddle];
if (FKeyState[VK_RBUTTON] and 128) <> 0 then
FShift:= FShift + [ssRight];
if (FKeyState[VK_SELECT] and 128) <> 0 then
FShift:= FShift + [ssDouble];
//ssDouble, ssTouch, ssPen, ssCommand
end;
procedure TJDCustomBreadcrumb.WMKeyDown(var Message: TWMKeyDown);
begin
GetShiftState;
inherited;
end;
procedure TJDCustomBreadcrumb.WMKeyUp(var Message: TWMKeyUp);
begin
GetShiftState;
inherited;
end;
procedure TJDCustomBreadcrumb.WMSysKeyDown(var Message: TWMSysKeyDown);
begin
inherited;
end;
procedure TJDCustomBreadcrumb.WMSysKeyUp(var Message: TWMSysKeyUp);
begin
inherited;
end;
procedure TJDCustomBreadcrumb.WMLButtonDown(var Message: TWMLButtonDown);
var
P: TPoint;
X: Integer;
I: TJDBreadcrumbItem;
begin
GetShiftState;
P:= Point(Message.XPos, Message.YPos);
FMouseDownPos:= P;
FMouseDownIndex:= -1;
for X := 0 to FItems.Count - 1 do begin
I:= FItems[X];
if PointInPolygon(P, I.Points) then begin
FMouseDownIndex:= X;
DoSelectItem;
if assigned(FOnItemMouseDown) then
FOnItemMouseDown(Self, I, mbLeft, FShift, P.X, P.Y);
Break;
end;
end;
inherited;
end;
procedure TJDCustomBreadcrumb.WMLButtonUp(var Message: TWMLButtonUp);
var
P: TPoint;
I: TJDBreadcrumbItem;
begin
GetShiftState;
P:= ScreenToClient(Point(Message.XPos, Message.YPos));
I:= FItems[FMouseDownIndex];
FMouseDownIndex:= -1;
if assigned(FOnItemMouseUp) then
FOnItemMouseUp(Self, I, mbLeft, FShift, P.X, P.Y);
inherited;
end;
procedure TJDCustomBreadcrumb.WMMButtonDown(var Message: TWMMButtonDown);
begin
inherited;
end;
procedure TJDCustomBreadcrumb.WMMButtonUp(var Message: TWMMButtonUp);
begin
inherited;
end;
procedure TJDCustomBreadcrumb.WMRButtonDown(var Message: TWMRButtonDown);
begin
inherited;
end;
procedure TJDCustomBreadcrumb.WMRButtonUp(var Message: TWMRButtonUp);
begin
inherited;
end;
{ TJDBreadcrumbItem }
constructor TJDBreadcrumbItem.Create(AOwner: TCollection);
begin
inherited Create(AOwner);
FIndex:= 0;
FLength:= 150;
FCaption:= 'New Item';
FSubCaption:= '';
FEnabled:= True;
end;
destructor TJDBreadcrumbItem.Destroy;
begin
inherited;
end;
function TJDBreadcrumbItem.GetBorderColor: TColor;
begin
case ItemState of
stPending: Result:= Breadcrumb.StylePending.BorderColor;
stSelected: Result:= Breadcrumb.StyleSelected.BorderColor;
stPassed: Result:= Breadcrumb.StylePassed.BorderColor;
stDisabled: Result:= Breadcrumb.StyleDisabled.BorderColor;
end;
end;
function TJDBreadcrumbItem.GetBorderWidth: Integer;
begin
case ItemState of
stPending: Result:= Breadcrumb.StylePending.BorderWidth;
stSelected: Result:= Breadcrumb.StyleSelected.BorderWidth;
stPassed: Result:= Breadcrumb.StylePassed.BorderWidth;
stDisabled: Result:= Breadcrumb.StyleDisabled.BorderWidth;
end;
end;
function TJDBreadcrumbItem.GetCaptionRect: TRect;
var
R: TRect;
W: Integer;
begin
R:= Rect(0, 0, 10, 50);
Breadcrumb.Canvas.Font.Assign(Font);
W:= DrawText(Breadcrumb.Canvas.Handle, Caption, System.Length(Caption),
R, DT_SINGLELINE or DT_CALCRECT);
Result:= R;
R:= ItemRect;
//Result.Left:= (Result.Width div 2) -
end;
function TJDBreadcrumbItem.GetColor: TColor;
begin
case ItemState of
stPending: Result:= Breadcrumb.StylePending.Color;
stSelected: Result:= Breadcrumb.StyleSelected.Color;
stPassed: Result:= Breadcrumb.StylePassed.Color;
stDisabled: Result:= Breadcrumb.StyleDisabled.Color;
end;
end;
function TJDBreadcrumbItem.GetFont: TFont;
begin
case ItemState of
stPending: Result:= Breadcrumb.StylePending.CaptionFont;
stSelected: Result:= Breadcrumb.StyleSelected.CaptionFont;
stPassed: Result:= Breadcrumb.StylePassed.CaptionFont;
stDisabled: Result:= Breadcrumb.StyleDisabled.CaptionFont;
end;
end;
function TJDBreadcrumbItem.GetItemRect: TRect;
var
X: Integer;
C: Integer;
I: TJDBreadcrumbItem;
begin
C:= Breadcrumb.Gap;
case Breadcrumb.Direction of
bdHorizontal: begin
for X := 0 to Collection.Count - 1 do begin
if X = Index then Break;
I:= TJDBreadcrumbItem(Collection.Items[X]);
C:= C + Breadcrumb.Gap + I.Length - Breadcrumb.Indent;
end;
Result.Left:= C - Breadcrumb.Indent;
Result.Top:= Breadcrumb.Margin;
Result.Right:= Result.Left + Length;
Result.Bottom:= Breadcrumb.ClientHeight - Breadcrumb.Margin;
end;
bdVertical: begin
for X := 0 to Collection.Count - 1 do begin
if X = Index then Break;
I:= TJDBreadcrumbItem(Collection.Items[X]);
C:= C + Breadcrumb.Gap + I.Length - Breadcrumb.Indent;
end;
Result.Left:= Breadcrumb.Margin;
Result.Top:= C - Breadcrumb.Indent;
Result.Right:= Breadcrumb.ClientWidth - Breadcrumb.Margin;
Result.Bottom:= Result.Top + Length;
end;
end;
end;
function TJDBreadcrumbItem.GetItemState: TBreadcrumbState;
var
I: Integer;
begin
if Enabled then begin
I:= Breadcrumb.ItemIndex;
if (Index > I) then
Result:= stPending
else if (Index = I) then
Result:= stSelected
else if (Index < I) then
Result:= stPassed;
end else begin
Result:= stDisabled;
end;
end;
function TJDBreadcrumbItem.GetLength: Integer;
begin
case Breadcrumb.Sizing of
bsManual: begin
Result:= FLength;
end;
bsAuto: begin
//Calculate text width
Result:= FLength;
end;
bsStretch: begin
case Breadcrumb.FDirection of
bdHorizontal: Result:=
((Breadcrumb.ClientWidth) div Collection.Count) +
Breadcrumb.Indent - Breadcrumb.Gap;
bdVertical: Result:=
((Breadcrumb.ClientHeight) div Collection.Count) +
Breadcrumb.Indent - Breadcrumb.Gap;
end;
end;
end;
end;
function TJDBreadcrumbItem.GetOwner: TJDBreadcrumb;
begin
Result:= TJDBreadcrumb(Collection.Owner);
end;
function TJDBreadcrumbItem.GetPoints: TPoints;
var
Half: Integer;
Dist: Integer;
Br: TJDBreadcrumb;
Wid: Integer;
begin
//Return polygon points
Br:= Breadcrumb;
if Index = 0 then
System.SetLength(Result, 6)
else
System.SetLength(Result, 7);
case Br.Direction of
bdHorizontal: begin
Dist:= ItemRect.Left;
Wid:= Breadcrumb.ClientHeight - (Br.Margin * 2);
Half:= Wid div 2;
Result[0]:= Point(Br.Margin+Dist, Br.Margin);
Result[1]:= Point(Br.Margin+Dist+Length-Br.Indent, Br.Margin);
Result[2]:= Point(Br.Margin+Dist+Length, BR.Margin+Half);
Result[3]:= Point(Br.Margin+Dist+Length-Br.Indent, Br.Margin+Wid);
Result[4]:= Point(Br.Margin+Dist, Br.Margin+Wid);
if Index = 0 then begin
Result[5]:= Point(Br.Margin+Dist, Br.Margin);
end else begin
Result[5]:= Point(Br.Margin+Dist+Br.Indent, BR.Margin+Half);
Result[6]:= Point(Br.Margin+Dist, Br.Margin);
end;
end;
bdVertical: begin
Dist:= Self.ItemRect.Top;
Wid:= Breadcrumb.ClientWidth - (Br.Margin * 2);
Half:= Wid div 2;
if Index = 0 then begin
Result[0]:= Point(Br.Margin, Br.Margin+Dist);
Result[1]:= Point(Br.Margin+Wid, Br.Margin+Dist);
Result[2]:= Point(Br.Margin+Wid, Br.Margin+Dist+Length-Br.Indent);
Result[3]:= Point(Br.Margin+Half, Br.Margin+Dist+Length);
Result[4]:= Point(Br.Margin, Br.Margin+Dist+Length-Br.Indent);
Result[5]:= Point(Br.Margin, Br.Margin+Dist);
end else begin
Result[0]:= Point(Br.Margin, Br.Margin+Dist);
Result[1]:= Point(Br.Margin+Half, Br.Margin+Dist+Br.Indent);
Result[2]:= Point(Br.Margin+Wid, Br.Margin+Dist);
Result[3]:= Point(Br.Margin+Wid, Br.Margin+Dist+Length-Br.Indent);
Result[4]:= Point(Br.Margin+Half, Br.Margin+Dist+Length);
Result[5]:= Point(Br.Margin, Br.Margin+Dist+Length-Br.Indent);
Result[6]:= Point(Br.Margin, Br.Margin+Dist);
end;
end;
end;
end;
procedure TJDBreadcrumbItem.Invalidate;
begin
TJDBreadcrumb(TJDBreadcrumbItems(Self.Collection).Owner).Invalidate;
end;
procedure TJDBreadcrumbItem.SetCaption(const Value: TCaption);
begin
if Value <> FCaption then begin
FCaption := Value;
Invalidate;
end;
end;
procedure TJDBreadcrumbItem.SetEnabled(const Value: Boolean);
begin
if Value <> FEnabled then begin
FEnabled := Value;
Invalidate;
end;
end;
procedure TJDBreadcrumbItem.SetSubCaption(const Value: TCaption);
begin
if Value <> FSubCaption then begin
FSubCaption := Value;
Invalidate;
end;
end;
procedure TJDBreadcrumbItem.SetLength(const Value: Integer);
begin
if Value <> FLength then begin
FLength := Value;
//Breadcrumb.Sizing:= bsManual;
Invalidate;
end;
end;
{ TJDBreadcrumbItems }
constructor TJDBreadcrumbItems.Create(AOwner: TComponent);
begin
inherited Create(AOwner, TJDBreadcrumbItem);
end;
destructor TJDBreadcrumbItems.Destroy;
begin
inherited;
end;
function TJDBreadcrumbItems.Add: TJDBreadcrumbItem;
begin
Result:= TJDBreadcrumbItem(inherited Add);
Result.FIndex:= 0;
Result.FLength:= 150;
Result.FCaption:= 'New Item';
Result.FSubCaption:= '';
Result.FEnabled:= True;
Invalidate;
end;
procedure TJDBreadcrumbItems.Delete(const Index: Integer);
begin
inherited Delete(Index);
Invalidate;
end;
function TJDBreadcrumbItems.GetItem(Index: Integer): TJDBreadcrumbItem;
begin
Result:= nil;
if (Index >= 0) and (Index < Count) then begin
Result:= TJDBreadcrumbItem(inherited Items[Index]);
end;
end;
procedure TJDBreadcrumbItems.Invalidate;
var
X: Integer;
begin
for X := 0 to Count - 1 do
Items[X].FIndex:= X;
TJDBreadcrumb(Owner).Invalidate;
end;
procedure TJDBreadcrumbItems.SetItem(Index: Integer;
const Value: TJDBreadcrumbItem);
begin
if (Index >= 0) and (Index < Count) then begin
inherited Items[Index]:= Value;
Invalidate;
end;
end;
{ TJDBreadcrumbItemStyle }
procedure TJDBreadcrumbItemStyle.Changed;
begin
if assigned(FOnChange) then
FOnChange(Self);
end;
constructor TJDBreadcrumbItemStyle.Create;
begin
FCaptionFont:= TFont.Create;
FCaptionFont.OnChange:= FontChanged;
FSubCaptionFont:= TFont.Create;
FSubCaptionFont.OnChange:= FontChanged;
FColor:= clBlue;
FBorderWidth:= 1;
FBorderColor:= clGray;
end;
destructor TJDBreadcrumbItemStyle.Destroy;
begin
FCaptionFont.Free;
FSubCaptionFont.Free;
inherited;
end;
procedure TJDBreadcrumbItemStyle.FontChanged(Sender: TObject);
begin
Changed;
end;
procedure TJDBreadcrumbItemStyle.SetColor(const Value: TColor);
begin
if Value <> FColor then begin
FColor := Value;
Changed;
end;
end;
procedure TJDBreadcrumbItemStyle.SetSubCaptionFont(const Value: TFont);
begin
FSubCaptionFont := Value;
Changed;
end;
procedure TJDBreadcrumbItemStyle.SetBorderColor(const Value: TColor);
begin
if Value <> FBorderColor then begin
FBorderColor := Value;
Changed;
end;
end;
procedure TJDBreadcrumbItemStyle.SetBorderWidth(const Value: Integer);
begin
if Value <> FBorderWidth then begin
FBorderWidth := Value;
Changed;
end;
end;
procedure TJDBreadcrumbItemStyle.SetCaptionFont(const Value: TFont);
begin
FCaptionFont.Assign(Value);
Changed;
end;
end.JD Solutions
