TFlowPanel alike in D5 - delphi

I am looking for an implementation of TFlowPanel (or similar) that will work with D5.
Basically I need the TFlowPanel to work inside a TScrollBox (with Vertical scroll bar), so the controls will wrap based on the Width of that TScrollBox.
The images basically show what I need:
After resizing the controls are automatically repositioned:
With Vertical scroll bar:

Just a concept. No various FlowTypes, and no possibility to change the order of the controls. You could still move them around by changing the order in the DFM, I think, or by resetting the parent.
The panel sizes vertically to fit all controls. This means, that when you put it inside a scrollbox it will automatically work.
unit uAlignPanel;
interface
uses
Windows, SysUtils, Classes, Controls, ExtCtrls;
type
TAlignPanel = class(TPanel)
protected
procedure SetChildOrder(Child: TComponent; Order: Integer); overload; override;
procedure SetZOrder(TopMost: Boolean); override;
public
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure Insert(AControl: TControl);
procedure Append(AControl: TControl);
function GetChildOrder(Child: TControl): Integer;
procedure SetChildOrder(Child: TControl; Order: Integer); reintroduce; overload; virtual;
procedure MoveChildBefore(Child: TControl; Sibling: TControl); virtual;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('StackOverflow', [TAlignPanel]);
end;
{ TAlignPanel }
procedure TAlignPanel.AlignControls(AControl: TControl; var Rect: TRect);
var
i: Integer;
x, y: Integer;
LineHeight: Integer;
begin
x := 0; y := 0;
LineHeight := 0;
for i := 0 to ControlCount - 1 do
begin
if x + Controls[i].Width > ClientWidth then
begin
x := 0;
y := y + LineHeight;
LineHeight := 0;
end;
Controls[i].Top := y;
Controls[i].Left := x;
x := x + Controls[i].Width;
if Controls[i].Height > LineHeight then
LineHeight := Controls[i].Height;
end;
// Height + 1. Not only looks nices, but also prevents a small redrawing
// problem of the bottom line of the panel when adding controls.
ClientHeight := y + LineHeight + 1;
end;
procedure TAlignPanel.Append(AControl: TControl);
begin
AControl.Parent := Self;
AControl.BringToFront;
Realign;
end;
function TAlignPanel.GetChildOrder(Child: TControl): Integer;
begin
for Result := 0 to ControlCount - 1 do
if Controls[Result] = Child then
Exit;
Result := -1;
end;
procedure TAlignPanel.Insert(AControl: TControl);
begin
AControl.Parent := Self;
AControl.SendToBack;
Realign;
end;
procedure TAlignPanel.MoveChildBefore(Child, Sibling: TControl);
var
CurrentIndex: Integer;
NewIndex: Integer;
begin
if Child = Sibling then
raise Exception.Create('Child and sibling cannot be the same');
CurrentIndex := GetChildOrder(Child);
if CurrentIndex = -1 then
raise Exception.CreateFmt( 'Control ''%s'' is not a child of panel ''%s''',
[Sibling.Name, Name]);
if Sibling <> nil then
begin
NewIndex := GetChildOrder(Sibling);
if NewIndex = -1 then
raise Exception.CreateFmt( 'Sibling ''%s'' is not a child of panel ''%s''',
[Sibling.Name, Name]);
if CurrentIndex < NewIndex then
Dec(NewIndex);
end
else
NewIndex := ControlCount;
SetChildOrder(Child, NewIndex);
end;
procedure TAlignPanel.SetChildOrder(Child: TComponent; Order: Integer);
begin
inherited;
Realign;
end;
procedure TAlignPanel.SetChildOrder(Child: TControl; Order: Integer);
begin
SetChildOrder(TComponent(Child), Order);
end;
procedure TAlignPanel.SetZOrder(TopMost: Boolean);
begin
inherited;
Realign;
end;
end.

Related

How to create popup menu with scroll bar that also supports sub-menus

I want to add scroll bars (and/or scroll wheel support) to my existing Delphi application's popup menus, because they are often higher than the screen, and the built in scrolling is not good enough. How to make a popup menu with scrollbar? would be a great solution for me, except that it doesn't support sub-menus, which I absolutely require. The author of that solution hasn't been on StackOverflow since last July, so I don't think he'll reply to my comment. Can anyone see how to modify that code to add support for sub-menus? In case it matters, I need it to work with Delphi 2007.
I share #KenWhite's reservations about how users might receive a huge menu. So apologies to him and readers whose sensibilities the following might offend ;=)
Anyway, I hope the code below shows that in principle, it is straightforward
to create a TreeView based on a TPopUpMenu (see the routine PopUpMenuToTree) which reflects the structure of the PopUpMenu, including sub-items,
and make use of the TreeView's automatic vertical scroll bar. In the code, the
PopUpMenu happens to be on the same form as the TreeView, but that's only for
compactness, of course - the PopUpMenu could be on anothe form entirely.
As mentioned in a comment, personally I would base something like this on a
TVirtualTreeView (http://www.soft-gems.net/index.php/controls/virtual-treeview)
because it is far more customisable than a standard TTreeView.
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
TreeView1: TTreeView; // alClient-aligned
Start1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure TreeView1Click(Sender: TObject);
private
protected
procedure MenuItemClick(Sender : TObject);
procedure PopUpMenuToTree(PopUpMenu : TPopUpMenu; TreeView : TTreeView);
public
end;
var
Form1: TForm1;
[...]
procedure TForm1.FormCreate(Sender: TObject);
var
Item,
SubItem : TMenuItem;
i,
j : Integer;
begin
// (Over)populate a PopUpMenu
for i := 1 to 50 do begin
Item := TMenuItem.Create(PopUpMenu1);
Item.Caption := 'Item ' + IntToStr(i);
Item.OnClick := MenuItemClick;
PopUpMenu1.Items.Add(Item);
for j := 1 to 5 do begin
SubItem := TMenuItem.Create(PopUpMenu1);
SubItem.Caption := Format('Item %d Subitem %d ', [i, j]);
SubItem.OnClick := MenuItemClick;
Item.Add(SubItem);
end;
end;
// Populate a TreeView from the PopUpMenu
PopUpMenuToTree(PopUpMenu1, TreeView1);
end;
procedure TForm1.MenuItemClick(Sender: TObject);
var
Item : TMenuItem;
begin
if Sender is TMenuItem then
Caption := TMenuItem(Sender).Caption + ' clicked';
end;
procedure TForm1.PopUpMenuToTree(PopUpMenu: TPopUpMenu;
TreeView: TTreeView);
// Populates the TreeView with the Items in the PopUpMenu
var
i : Integer;
Item : TMenuItem;
RootNode : TTreeNode;
procedure AddItem(Item : TMenuItem; ParentNode : TTreeNode);
var
Node : TTreeNode;
j : Integer;
begin
Node := TreeView.Items.AddChildObject(ParentNode, Item.Caption, Item);
for j := 0 to Item.Count - 1 do begin
AddItem(Item.Items[j], Node);
end;
end;
begin
TreeView.Items.BeginUpdate;
TreeView.Items.Clear;
try
for i := 0 to PopUpMenu.Items.Count - 1 do begin
AddItem(PopUpMenu.Items[i], Nil);
end;
finally
TreeView.Items.EndUpdate;
end;
end;
procedure TForm1.TreeView1Click(Sender: TObject);
var
Node : TTreeNode;
Item : TMenuItem;
begin
if Sender is TTreeView then begin
Node := TTreeView(Sender).Selected;
Item := TMenuItem(Node.Data);
Item.Click;
end;
end;
Here's what I have done, by merging How to make a popup menu with scrollbar?, MartynA's code, and some of my own:
unit PopupUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, Menus, ComCtrls;
type
TPopupMode = (pmStandard, pmCustom);
TPopupMenu = class(Menus.TPopupMenu)
private
FPopupForm: TForm;
FPopupMode: TPopupMode;
public
constructor Create(AOwner: TComponent); override;
procedure Popup(X, Y: Integer); override;
property PopupForm: TForm read FPopupForm write FPopupForm;
property PopupMode: TPopupMode read FPopupMode write FPopupMode;
end;
type
TPopupForm = class(TForm)
private
FPopupForm: TForm;
FPopupMenu: TPopupMenu;
FTreeView: TTreeView;
procedure DoResize;
procedure TreeViewClick(Sender: TObject);
procedure TreeViewCollapsedOrExpanded(Sender: TObject; Node: TTreeNode);
procedure TreeViewKeyPress(Sender: TObject; var Key: Char);
procedure WMActivate(var AMessage: TWMActivate); message WM_ACTIVATE;
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent; APopupForm: TForm;
APopupMenu: TPopupMenu); reintroduce;
end;
var
PopupForm: TPopupForm;
implementation
{$R *.dfm}
{ TPopupForm }
constructor TPopupForm.Create(AOwner: TComponent; APopupForm: TForm;
APopupMenu: TPopupMenu);
procedure AddItem(Item : TMenuItem; ParentNode : TTreeNode);
var
I : Integer;
Node : TTreeNode;
begin
if Item.Caption <> '-' then begin
Node := FTreeView.Items.AddChildObject(ParentNode, Item.Caption, Item);
Node.ImageIndex := Item.ImageIndex;
for I := 0 to Item.Count - 1 do begin
AddItem(Item.Items[I], Node);
end;
end;
end;
var
I: Integer;
begin
inherited Create(AOwner);
BorderStyle := bsNone;
FPopupForm := APopupForm;
FPopupMenu := APopupMenu;
FTreeView := TTreeView.Create(Self);
FTreeView.Parent := Self;
FTreeView.Align := alClient;
FTreeView.BorderStyle := bsSingle;
FTreeView.Color := clMenu;
FTreeView.Images := FPopupMenu.Images;
FTreeView.ReadOnly := TRUE;
FTreeView.ShowHint := FALSE;
FTreeView.ToolTips := FALSE;
FTreeView.OnClick := TreeViewClick;
FTreeView.OnCollapsed := TreeViewCollapsedOrExpanded;
FTreeView.OnExpanded := TreeViewCollapsedOrExpanded;
FTreeView.OnKeyPress := TreeViewKeyPress;
FTreeView.Items.BeginUpdate;
try
FTreeView.Items.Clear;
for I := 0 to FPopupMenu.Items.Count - 1 do
begin
AddItem(FPopupMenu.Items[I], NIL);
end;
finally
FTreeView.Items.EndUpdate;
end;
DoResize;
end;
procedure TPopupForm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
procedure TPopupForm.DoResize;
const
BORDER = 2;
var
ItemRect, TVRect : TRect;
MF : TForm;
Node : TTreeNode;
begin
TVRect := Rect(0, 0, 0, 0);
Node := FTreeView.Items[0];
while Node <> NIL do begin
ItemRect := Node.DisplayRect(TRUE);
ItemRect.Right := ItemRect.Right + FTreeView.Images.Width + 1;
if ItemRect.Left < TVRect.Left then
TVRect.Left := ItemRect.Left;
if ItemRect.Right > TVRect.Right then
TVRect.Right := ItemRect.Right;
if ItemRect.Top < TVRect.Top then
TVRect.Top := ItemRect.Top;
if ItemRect.Bottom > TVRect.Bottom then
TVRect.Bottom := ItemRect.Bottom;
Node := Node.GetNextVisible;
end;
MF := Application.MainForm;
if Top + TVRect.Bottom - TVRect.Top > MF.Top + MF.ClientHeight then begin
TVRect.Bottom := TVRect.Bottom -
(Top + TVRect.Bottom - TVRect.Top - (MF.Top + MF.ClientHeight));
end;
if Left + TVRect.Right - TVRect.Left > MF.Left + MF.ClientWidth then begin
TVRect.Right := TVRect.Right -
(Left + TVRect.Right - TVRect.Left - (MF.Left + MF.ClientWidth));
end;
ClientHeight := TVRect.Bottom - TVRect.Top + BORDER * 2;
ClientWidth := TVRect.Right - TVRect.Left + BORDER * 2;
end;
procedure TPopupForm.TreeViewClick(Sender: TObject);
var
Node : TTreeNode;
Item : TMenuItem;
begin
if Sender is TTreeView then begin
Node := TTreeView(Sender).Selected;
if assigned(Node) then begin
Item := TMenuItem(Node.Data);
if assigned(Item.OnClick) then begin
Item.Click;
Close;
end;
end;
end;
end;
procedure TPopupForm.TreeViewCollapsedOrExpanded(Sender: TObject;
Node: TTreeNode);
begin
DoResize;
end;
procedure TPopupForm.TreeViewKeyPress(Sender: TObject; var Key: Char);
begin
if Ord(Key) = VK_RETURN then begin
TreeViewClick(Sender);
end
else if Ord(Key) = VK_ESCAPE then begin
Close;
end;
end;
procedure TPopupForm.WMActivate(var AMessage: TWMActivate);
begin
SendMessage(FPopupForm.Handle, WM_NCACTIVATE, 1, 0);
inherited;
if AMessage.Active = WA_INACTIVE then
Release;
FTreeView.Select(NIL, []);
end;
{ TPopupMenu }
constructor TPopupMenu.Create(AOwner: TComponent);
begin
inherited;
FPopupMode := pmStandard;
end;
procedure TPopupMenu.Popup(X, Y: Integer);
begin
case FPopupMode of
pmCustom:
with TPopupForm.Create(nil, FPopupForm, Self) do
begin
Top := Y;
Left := X;
Show;
end;
pmStandard: inherited;
end;
end;
end.

How to create a custom control which can scroll with a fixed row and column?

I'm trying to figure out how I can make a custom control in a way where user can scroll in all directions, but with a fixed row and column. A grid is not suitable for what I'm trying to do, because it scrolls column by column. I need horizontal scrolling to be smooth, pixel by pixel. I have no use for columns, only visual grid lines. Vertical scrolling should scroll not only the area on the right, but also the fixed region on the left. Same with horizontal scrolling: the header row should move along with the horizontal scrollbar.
This is just a rough draft of the final control I'm working on.
Note how the scrollbars do not cover the full control, only the larger region. The fixed column/row should also be able to move along with their corresponding scrollbar.
How should I implement the scrollbars to make this possible?
PS - This is to replace a much more thorough question which was deleted for being a mis-leading request. So sorry if I'm lacking details which you might need to know.
First, I thought you could do with this component (sample image) which is capable of holding controls in cells, but from your comment I understand that you want to draw everything yourself. So I wrote a 'THeaderGrid' component:
procedure TForm1.FormCreate(Sender: TObject);
begin
with THeaderGrid.Create(Self) do
begin
Align := alClient;
OnDrawCell := DrawCell;
OnDrawColHeader := DrawCell;
OnDrawRowHeader := DrawCell;
Parent := Self;
end;
end;
procedure TForm1.DrawCell(Sender: TObject; ACanvas: TCanvas; ACol,
ARow: Integer; R: TRect);
begin
ACanvas.TextOut(R.Left + 2, R.Top + 2, Format('(%d,%d)', [ACol, ARow]));
end;
The component is build up out of three TPaintScroller controls (a TPaintBox on a TScrollBox). Actually, for both headers, TScrollBox is a little bit heavyweighted, but it was kind of handy to use the same control as for the data region with the cells.
There are three OnDraw events, one for both headers and one for the cells, but you could all set them to the same handler, alike the example above. Distinguish each by the column or row index being -1.
unit HeaderGrid;
interface
uses
Classes, Controls, Windows, Messages, Graphics, Forms, ExtCtrls, StdCtrls;
type
TPaintEvent = procedure(ACanvas: TCanvas) of object;
TPaintScroller = class(TScrollingWinControl)
private
FOnPaint: TPaintEvent;
FOnScroll: TNotifyEvent;
FPainter: TPaintBox;
function GetPaintHeight: Integer;
function GetPaintWidth: Integer;
function GetScrollBars: TScrollStyle;
procedure SetPaintHeight(Value: Integer);
procedure SetPaintWidth(Value: Integer);
procedure SetScrollBars(Value: TScrollStyle);
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMHScroll(var Message: TWMScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMScroll); message WM_VSCROLL;
protected
procedure CreateParams(var Params: TCreateParams); override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
procedure DoPaint(Sender: TObject); virtual;
procedure DoScroll; virtual;
procedure PaintWindow(DC: HDC); override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
published
property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
property PaintHeight: Integer read GetPaintHeight write SetPaintHeight;
property PaintWidth: Integer read GetPaintWidth write SetPaintWidth;
property ScrollBars: TScrollStyle read GetScrollBars write SetScrollBars
default ssBoth;
end;
TDrawCellEvent = procedure(Sender: TObject; ACanvas: TCanvas; ACol,
ARow: Integer; R: TRect) of object;
THeaderGrid = class(TCustomControl)
private
FCellScroller: TPaintScroller;
FColCount: Integer;
FColHeader: TPaintScroller;
FColWidth: Integer;
FOnDrawCell: TDrawCellEvent;
FOnDrawColHeader: TDrawCellEvent;
FOnDrawRowHeader: TDrawCellEvent;
FRowCount: Integer;
FRowHeader: TPaintScroller;
FRowHeight: Integer;
procedure CellsScrolled(Sender: TObject);
function GetColHeaderHeight: Integer;
function GetRowHeaderWidth: Integer;
procedure PaintCells(ACanvas: TCanvas);
procedure PaintColHeader(ACanvas: TCanvas);
procedure PaintRowHeader(ACanvas: TCanvas);
procedure SetColCount(Value: Integer);
procedure SetColHeaderHeight(Value: Integer);
procedure SetColWidth(Value: Integer);
procedure SetRowCount(Value: Integer);
procedure SetRowHeaderWidth(Value: Integer);
procedure SetRowHeight(Value: Integer);
procedure UpdateSize;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure DoDrawCell(ACanvas: TCanvas; ACol, ARow: Integer;
R: TRect); virtual;
procedure DoDrawColHeader(ACanvas: TCanvas; ACol: Integer;
R: TRect); virtual;
procedure DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
R: TRect); virtual;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
procedure MouseWheelHandler(var Message: TMessage); override;
published
property ColCount: Integer read FColCount write SetColCount default 5;
property ColHeaderHeight: Integer read GetColHeaderHeight
write SetColHeaderHeight default 24;
property ColWidth: Integer read FColWidth write SetColWidth default 64;
property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
property OnDrawColHeader: TDrawCellEvent read FOnDrawColHeader
write FOnDrawColHeader;
property OnDrawRowHeader: TDrawCellEvent read FOnDrawRowHeader
write FOnDrawRowHeader;
property RowCount: Integer read FRowCount write SetRowCount default 5;
property RowHeaderWidth: Integer read GetRowHeaderWidth
write SetRowHeaderWidth default 64;
property RowHeight: Integer read FRowHeight write SetRowHeight default 24;
published
property Color;
property Font;
property ParentColor default False;
property TabStop default True;
end;
implementation
{ TPaintScroller }
constructor TPaintScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
HorzScrollBar.Tracking := True;
VertScrollBar.Tracking := True;
Width := 100;
Height := 100;
FPainter := TPaintBox.Create(Self);
FPainter.SetBounds(0, 0, 100, 100);
FPainter.OnPaint := DoPaint;
FPainter.Parent := Self;
end;
procedure TPaintScroller.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
function TPaintScroller.DoMouseWheel(Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
VertScrollBar.Position := VertScrollBar.Position - WheelDelta;
DoScroll;
Result := True;
end;
procedure TPaintScroller.DoPaint(Sender: TObject);
begin
if Assigned(FOnPaint) then
FOnPaint(FPainter.Canvas);
end;
procedure TPaintScroller.DoScroll;
begin
if Assigned(FOnScroll) then
FOnScroll(Self);
end;
function TPaintScroller.GetPaintHeight: Integer;
begin
Result := FPainter.Height;
end;
function TPaintScroller.GetPaintWidth: Integer;
begin
Result := FPainter.Width;
end;
function TPaintScroller.GetScrollBars: TScrollStyle;
begin
if HorzScrollBar.Visible and VertScrollBar.Visible then
Result := ssBoth
else if not HorzScrollBar.Visible and VertScrollBar.Visible then
Result := ssVertical
else if HorzScrollBar.Visible and not VertScrollBar.Visible then
Result := ssHorizontal
else
Result := ssNone;
end;
procedure TPaintScroller.PaintWindow(DC: HDC);
begin
with FPainter do
ExcludeClipRect(DC, 0, 0, Width + Left, Height + Top);
FillRect(DC, ClientRect, Brush.Handle);
end;
procedure TPaintScroller.Resize;
begin
DoScroll;
inherited Resize;
end;
procedure TPaintScroller.SetPaintHeight(Value: Integer);
begin
FPainter.Height := Value;
end;
procedure TPaintScroller.SetPaintWidth(Value: Integer);
begin
FPainter.Width := Value;
end;
procedure TPaintScroller.SetScrollBars(Value: TScrollStyle);
begin
HorzScrollBar.Visible := (Value = ssBoth) or (Value = ssHorizontal);
VertScrollBar.Visible := (Value = ssBoth) or (Value = ssVertical);
end;
procedure TPaintScroller.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TPaintScroller.WMHScroll(var Message: TWMScroll);
begin
inherited;
DoScroll;
end;
procedure TPaintScroller.WMVScroll(var Message: TWMScroll);
begin
inherited;
DoScroll;
end;
{ THeaderGrid }
procedure THeaderGrid.CellsScrolled(Sender: TObject);
begin
FColHeader.FPainter.Left := -FCellScroller.HorzScrollBar.Position;
FRowHeader.FPainter.Top := -FCellScroller.VertScrollBar.Position;
end;
constructor THeaderGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
ParentColor := False;
TabStop := True;
FCellScroller := TPaintScroller.Create(Self);
FCellScroller.Anchors := [akLeft, akTop, akRight, akBottom];
FCellScroller.OnPaint := PaintCells;
FCellScroller.OnScroll := CellsScrolled;
FCellScroller.AutoScroll := True;
FCellScroller.Parent := Self;
FColHeader := TPaintScroller.Create(Self);
FColHeader.Anchors := [akLeft, akTop, akRight];
FColHeader.OnPaint := PaintColHeader;
FColHeader.ScrollBars := ssNone;
FColHeader.Parent := Self;
FRowHeader := TPaintScroller.Create(Self);
FRowHeader.Anchors := [akLeft, akTop, akBottom];
FRowHeader.OnPaint := PaintRowHeader;
FRowHeader.ScrollBars := ssNone;
FRowHeader.Parent := Self;
Width := 320;
Height := 120;
ColCount := 5;
RowCount := 5;
ColWidth := 64;
RowHeight := 24;
ColHeaderHeight := 24;
RowHeaderWidth := 64;
end;
procedure THeaderGrid.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure THeaderGrid.DoDrawCell(ACanvas: TCanvas; ACol, ARow: Integer;
R: TRect);
begin
if Assigned(FOnDrawCell) then
FOnDrawCell(Self, ACanvas, ACol, ARow, R);
end;
procedure THeaderGrid.DoDrawColHeader(ACanvas: TCanvas; ACol: Integer;
R: TRect);
begin
if Assigned(FOnDrawColHeader) then
FOnDrawColHeader(Self, ACanvas, ACol, -1, R);
end;
procedure THeaderGrid.DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
R: TRect);
begin
if Assigned(FOnDrawRowHeader) then
FOnDrawRowHeader(Self, ACanvas, -1, ARow, R);
end;
function THeaderGrid.GetColHeaderHeight: Integer;
begin
Result := FColHeader.Height;
end;
function THeaderGrid.GetRowHeaderWidth: Integer;
begin
Result := FRowHeader.Width;
end;
procedure THeaderGrid.MouseWheelHandler(var Message: TMessage);
begin
with Message do
Result := FCellScroller.Perform(CM_MOUSEWHEEL, WParam, LParam);
if Message.Result = 0 then
inherited MouseWheelHandler(Message);
end;
procedure THeaderGrid.Paint;
var
R: TRect;
begin
Canvas.Brush.Color := Color;
R := Rect(0, 0, RowHeaderWidth, ColHeaderHeight);
if IntersectRect(R, R, Canvas.ClipRect) then
Canvas.FillRect(R);
Canvas.Brush.Color := clBlack;
R := Rect(0, ColHeaderHeight, Width, ColHeaderHeight + 1);
if IntersectRect(R, R, Canvas.ClipRect) then
Canvas.FillRect(R);
R := Rect(RowHeaderWidth, 0, RowHeaderWidth + 1, Height);
if IntersectRect(R, R, Canvas.ClipRect) then
Canvas.FillRect(R);
end;
procedure THeaderGrid.PaintCells(ACanvas: TCanvas);
var
Col: Integer;
Row: Integer;
R: TRect;
Dummy: TRect;
begin
ACanvas.Brush.Color := Color;
ACanvas.Font := Font;
ACanvas.FillRect(ACanvas.ClipRect);
for Row := 0 to FRowCount - 1 do
begin
R := Bounds(0, Row * FRowHeight, FColWidth, FRowHeight);
for Col := 0 to FColCount - 1 do
begin
if IntersectRect(Dummy, R, ACanvas.ClipRect) then
begin
DoDrawCell(ACanvas, Col, Row, R);
if ACanvas.Pen.Style <> psSolid then
ACanvas.Pen.Style := psSolid;
if ACanvas.Pen.Color <> clSilver then
ACanvas.Pen.Color := clSilver;
ACanvas.MoveTo(R.Left, R.Bottom - 1);
ACanvas.LineTo(R.Right - 1, R.Bottom - 1);
ACanvas.LineTo(R.Right - 1, R.Top - 1);
end;
OffsetRect(R, FColWidth, 0);
end;
end;
end;
procedure THeaderGrid.PaintColHeader(ACanvas: TCanvas);
var
Col: Integer;
R: TRect;
Dummy: TRect;
begin
ACanvas.Brush.Color := Color;
ACanvas.Font := Font;
ACanvas.FillRect(ACanvas.ClipRect);
R := Rect(0, 0, FColWidth, ColHeaderHeight);
for Col := 0 to FColCount - 1 do
begin
if IntersectRect(Dummy, R, ACanvas.ClipRect) then
DoDrawColHeader(ACanvas, Col, R);
OffsetRect(R, FColWidth, 0);
end;
end;
procedure THeaderGrid.PaintRowHeader(ACanvas: TCanvas);
var
Row: Integer;
R: TRect;
Dummy: TRect;
begin
ACanvas.Brush.Color := Color;
ACanvas.Font := Font;
ACanvas.FillRect(ACanvas.ClipRect);
R := Rect(0, 0, RowHeaderWidth, FRowHeight);
for Row := 0 to FRowCount - 1 do
begin
if IntersectRect(Dummy, R, ACanvas.ClipRect) then
begin
DoDrawRowHeader(ACanvas, Row, R);
if ACanvas.Pen.Style <> psSolid then
ACanvas.Pen.Style := psSolid;
if ACanvas.Pen.Color <> clSilver then
ACanvas.Pen.Color := clSilver;
ACanvas.MoveTo(R.Left, R.Bottom - 1);
ACanvas.LineTo(R.Right - 1, R.Bottom - 1);
end;
OffsetRect(R, 0, FRowHeight);
end;
end;
procedure THeaderGrid.SetColCount(Value: Integer);
begin
if FColCount <> Value then
begin
FColCount := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.SetColHeaderHeight(Value: Integer);
begin
if Value >= 0 then
begin
FColHeader.Height := Value;
FRowHeader.BoundsRect := Rect(0, Value + 1, RowHeaderWidth, Height);
FCellScroller.BoundsRect := Rect(RowHeaderWidth + 1, Value + 1, Width,
Height);
end;
end;
procedure THeaderGrid.SetColWidth(Value: Integer);
begin
if FColWidth <> Value then
begin
FColWidth := Value;
FCellScroller.HorzScrollBar.Increment := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.SetRowCount(Value: Integer);
begin
if FRowCount <> Value then
begin
FRowCount := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.SetRowHeaderWidth(Value: Integer);
begin
if Value >= 0 then
begin
FRowHeader.Width := Value;
FColHeader.BoundsRect := Rect(Value + 1, 0, Width, ColHeaderHeight);
FCellScroller.BoundsRect := Rect(Value + 1, ColHeaderHeight + 1, Width,
Height);
end;
end;
procedure THeaderGrid.SetRowHeight(Value: Integer);
begin
if FRowHeight <> Value then
begin
FRowHeight := Value;
FCellScroller.VertScrollBar.Increment := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.UpdateSize;
begin
FColHeader.PaintWidth := FColCount * FColWidth;
FRowHeader.PaintHeight := FRowCount * FRowHeight;
FCellScroller.PaintWidth := FColCount * FColWidth;
FCellScroller.PaintHeight := FRowCount * FRowHeight;
end;
procedure THeaderGrid.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
end.
The easiest way is to make a control without scrollbars and then put scrollbars over it with fine control of their size and position.
With Delphi 3-5 you could then encapsulate it as your new control using Custom Containers Pack, and drop onto new forms just like u do with regular grid.
Since D5 CCP is no more available but limited analogue is given as VCL TFrame.
OR you can create those scrollbars in runtime - you need to search for Windows Handle creating routine, (trace TControl.Handle getter method), that might be ReCreateWnd or such, and as GDI handle created - create your scroll-bars over it.

How to resize a control inside a TFlowPanel using the Align property?

I have a few controls (namely, TDBChart) inside a TFlowPanel. When the user clicks on one of them, I'd like it to fill the entire flow panel's client area. But, it seems that changing the visible and align property of child controls inside a flow panel at run time doesn't have any effect. Is there a special trick to this? I found the Realign() method, but it doesn't seem to have any effect on the control's layout. Here's the code to my OnClick event:
var
AChart: TDBChart;
V: Boolean;
i: Integer;
begin
AChart := TDBChart(Sender);
if AChart.Align = alNone then
begin
V := False;
AChart.Align := alClient;
end else begin
V := True;
AChart.Align := alNone;
end;
for i := 0 to FlowPanel1.ControlCount - 1 do
if FlowPanel1.Controls[i] is TDBChart then
if FlowPanel1.Controls[i] <> AChart then
FlowPanel1.Controls[i].Visible := V;
end;
The charts are hidden or shown as expected, but ADBChart doesn't fill the entire flow panel's client area.
As by design, T(Custom)FlowPanel uses customized aligning of child controls, which is implemented in an overriden AlignControls method.
You can prevent this default behaviour by skipping it, falling back on that from its ancestor. Also, hiding all adjacent controls is not necessary. Bringing the clicked chart to front will suffice.
type
TFlowPanel = class(Vcl.ExtCtrls.TFlowPanel)
private
FFlowDisabled: Boolean;
procedure SetFlowDisabled(Value: Boolean);
protected
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
public
property FlowDisabled: Boolean read FFlowDisabled write SetFlowDisabled;
end;
...
{ TFlowPanel }
type
TWinControlAccess = class(TWinControl);
TAlignControls = procedure(Instance: TObject; AControl: TControl;
var Rect: TRect);
procedure TFlowPanel.AlignControls(AControl: TControl; var Rect: TRect);
begin
if FFlowDisabled then
// Skip inherited in TCustomFlowPanel:
TAlignControls(#TWinControlAccess.AlignControls)(Self, AControl, Rect)
else
inherited;
end;
procedure TFlowPanel.SetFlowDisabled(Value: Boolean);
begin
if FFlowDisabled <> Value then
begin
FFlowDisabled := Value;
Realign;
end;
end;
{ TForm1 }
procedure TForm1.DBChartClick(Sender: TObject);
const
FlowAligns: array[Boolean] of TAlign = (alNone, alClient);
var
Chart: TDBChart;
Panel: TFlowPanel;
DisableFlow: Boolean;
begin
Chart := TDBChart(Sender);
Panel := Chart.Parent as TFlowPanel;
DisableFlow := not Panel.FlowDisabled;
Chart.Align := FlowAligns[DisableFlow];
Chart.BringToFront;
Panel.FlowDisabled := DisableFlow;
end;
A FlowPanel does not care its controls' alignment settings, much like it doesn't care for their position - it is designed only to flow them.
One solution can be to derive a new class and override AlignControls, and in it, resize the control that would fill the surface accordingly. As an example:
type
TFlowPanel = class(extctrls.TFlowPanel)
protected
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
end;
..
procedure TFlowPanel.AlignControls(AControl: TControl; var Rect: TRect);
var
i, VisibleCount, VisibleControl: Integer;
begin
VisibleCount := 0;
VisibleControl := 0;
for i := 0 to ControlCount - 1 do
if Controls[i].Visible then begin
Inc(VisibleCount);
VisibleControl := i;
end;
if (VisibleCount = 1) and (Controls[VisibleControl] = AControl) and
(AControl.Align = alClient) then begin
// preserve 'Explicit..' settings
AControl.ControlState := AControl.ControlState + [csAligning];
AControl.SetBounds(1, 1, ClientWidth - 1, ClientHeight -1);
AControl.ControlState := AControl.ControlState - [csAligning];
end;
inherited;
end;
Then you can set all of your charts' click event to this handler:
var
AChart: TTDBChart;
procedure SetVisibility(Visible: Boolean);
var
i: Integer;
begin
for i := 0 to FlowPanel1.ControlCount - 1 do
if FlowPanel1.Controls[i] is TDBChart then
if FlowPanel1.Controls[i] <> AChart then
FlowPanel1.Controls[i].Visible := Visible;
end;
begin
AChart := TDBChart(Sender);
if AChart.Align = alNone then
begin
SetVisibility(False);
AChart.Align := alClient;
end else begin
AChart.Align := alNone; // set before changing visible
SetVisibility(True);
AChart.SetBounds(0, 0, AChart.ExplicitWidth, AChart.ExplicitHeight);
end;
end;
I should note that this is only good for a fixed sized flowpanel.

How to suppress standard RadioButton check behavior in Delphi?

I realize this one is a bit strange, so I'll explain. For a simple internet radio player I need a control to specify rating (1-5 "stars"). I have no experience or talent for graphical design, so all my attempts at drawing bitmaps look ridiculous/awful, take your pick. I couldn't find a 3rd party control with that functionality and look that fits standard VCL controls. So...
It occurred to me that I could achieve an OK look and consistency with Windows UI by using standard radiobuttons without captions, like this:
I had a vague (and incorrect) recollection of a GroupIndex property; assigning a different value to each radiobutton would let multiple radiobuttons be checked at the same time. Alas, TRadioButton does not have a GroupIndex property, so that's that.
Is it possible to completely override the natural radiobutton behavior, so that more than one button can show up as checked at the same time? Or,
Can I acquire all the bitmaps Windows uses for radiobuttons (I assume they're bitmaps) from the system and draw them directly, including theming support? In this case I would still like to retain all the effects of a radiobutton, including the mouse hover "glow", etc, so that means getting all the "native" bitmaps and drawing them as necessary, perhaps on a TPaintBox.
For maximum convenience, you could write a small control that draws native, themed, radio boxes:
unit StarRatingControl;
interface
uses
SysUtils, Windows, Messages, Graphics, Classes, Controls, UxTheme;
type
TStarRatingControl = class(TCustomControl)
private const
DEFAULT_SPACING = 4;
DEFAULT_NUM_STARS = 5;
FALLBACK_BUTTON_SIZE: TSize = (cx: 16; cy: 16);
private
{ Private declarations }
FRating: integer;
FBuffer: TBitmap;
FSpacing: integer;
FNumStars: integer;
FButtonStates: array of integer;
FButtonPos: array of TRect;
FButtonSize: TSize;
FDown: boolean;
PrevButtonIndex: integer;
PrevState: integer;
FOnChange: TNotifyEvent;
procedure SetRating(const Rating: integer);
procedure SetSpacing(const Spacing: integer);
procedure SetNumStars(const NumStars: integer);
procedure SwapBuffers;
procedure SetState(const ButtonIndex: integer; const State: integer);
protected
{ Protected declarations }
procedure WndProc(var Message: TMessage); override;
procedure Paint; override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ Public declarations }
published
{ Published declarations }
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property Rating: integer read FRating write SetRating default 3;
property Spacing: integer read FSpacing write SetSpacing default DEFAULT_SPACING;
property NumStars: integer read FNumStars write SetNumStars default DEFAULT_NUM_STARS;
property OnDblClick;
property OnKeyUp;
property OnKeyPress;
property OnKeyDown;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnMouseWheel;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseActivate;
property OnMouseMove;
property OnMouseUp;
property OnMouseDown;
property OnClick;
property Align;
property Anchors;
property Color;
end;
procedure Register;
implementation
uses Math;
function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
IsIntInInterval := (xmin <= x) and (x <= xmax);
end;
function PointInRect(const X, Y: integer; const Rect: TRect): boolean; inline;
begin
PointInRect := IsIntInInterval(X, Rect.Left, Rect.Right) and
IsIntInInterval(Y, Rect.Top, Rect.Bottom);
end;
procedure Register;
begin
RegisterComponents('Rejbrand 2009', [TStarRatingControl]);
end;
{ TStarRatingControl }
constructor TStarRatingControl.Create(AOwner: TComponent);
var
i: Integer;
begin
inherited;
FBuffer := TBitmap.Create;
FRating := 3;
FSpacing := DEFAULT_SPACING;
FNumStars := DEFAULT_NUM_STARS;
SetLength(FButtonStates, FNumStars);
SetLength(FButtonPos, FNumStars);
for i := 0 to high(FButtonStates) do
FButtonStates[i] := RBS_NORMAL;
FDown := false;
PrevButtonIndex := -1;
PrevState := -1;
end;
destructor TStarRatingControl.Destroy;
begin
FBuffer.Free;
inherited;
end;
procedure TStarRatingControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
i: integer;
begin
inherited;
FDown := true;
for i := 0 to FNumStars - 1 do
if PointInRect(X, Y, FButtonPos[i]) then
begin
SetState(i, RBS_PUSHED);
Exit;
end;
end;
procedure TStarRatingControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
i: Integer;
begin
inherited;
if FDown then Exit;
for i := 0 to FNumStars - 1 do
if PointInRect(X, Y, FButtonPos[i]) then
begin
SetState(i, RBS_HOT);
Exit;
end;
SetState(-1, -1);
end;
procedure TStarRatingControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
i: Integer;
begin
inherited;
for i := 0 to FNumStars - 1 do
if PointInRect(X, Y, FButtonPos[i]) and (i = PrevButtonIndex) and (FRating <> i + 1) then
begin
SetRating(i + 1);
if Assigned(FOnChange) then
FOnChange(Self);
end;
FDown := false;
MouseMove(Shift, X, Y);
end;
procedure TStarRatingControl.Paint;
var
t: HTHEME;
i: Integer;
begin
inherited;
FBuffer.Canvas.Brush.Color := Color;
FBuffer.Canvas.FillRect(ClientRect);
FButtonSize := FALLBACK_BUTTON_SIZE;
if UseThemes then
begin
t := OpenThemeData(Handle, 'BUTTON');
if t <> 0 then
try
GetThemePartSize(t, FBuffer.Canvas.Handle, BP_RADIOBUTTON, RBS_NORMAL, nil, TS_DRAW, FButtonSize);
for i := 0 to FNumStars - 1 do
with FButtonPos[i] do
begin
Left := i * (Spacing + FButtonSize.cx);
Top := (Self.Height - FButtonSize.cy) div 2;
Right := Left + FButtonSize.cx;
Bottom := Top + FButtonSize.cy;
end;
for i := 0 to FNumStars - 1 do
DrawThemeBackground(t,
FBuffer.Canvas.Handle,
BP_RADIOBUTTON,
IfThen(FRating > i, RBS_CHECKEDNORMAL) + FButtonStates[i],
FButtonPos[i],
nil);
finally
CloseThemeData(t);
end;
end
else
begin
for i := 0 to FNumStars - 1 do
with FButtonPos[i] do
begin
Left := i * (Spacing + FButtonSize.cx);
Top := (Self.Height - FButtonSize.cy) div 2;
Right := Left + FButtonSize.cx;
Bottom := Top + FButtonSize.cy;
end;
for i := 0 to FNumStars - 1 do
DrawFrameControl(FBuffer.Canvas.Handle,
FButtonPos[i],
DFC_BUTTON,
DFCS_BUTTONRADIO or IfThen(FRating > i, DFCS_CHECKED));
end;
SwapBuffers;
end;
procedure TStarRatingControl.SetNumStars(const NumStars: integer);
var
i: integer;
begin
if FNumStars <> NumStars then
begin
FNumStars := NumStars;
SetLength(FButtonStates, FNumStars);
SetLength(FButtonPos, FNumStars);
for i := 0 to high(FButtonStates) do
FButtonStates[i] := RBS_NORMAL;
Paint;
end;
end;
procedure TStarRatingControl.SetRating(const Rating: integer);
begin
if FRating <> Rating then
begin
FRating := Rating;
Paint;
end;
end;
procedure TStarRatingControl.SetSpacing(const Spacing: integer);
begin
if FSpacing <> Spacing then
begin
FSpacing := Spacing;
Paint;
end;
end;
procedure TStarRatingControl.SetState(const ButtonIndex, State: integer);
var
i: Integer;
begin
for i := 0 to FNumStars - 1 do
if i = ButtonIndex then
FButtonStates[i] := State
else
FButtonStates[i] := RBS_NORMAL;
if (PrevButtonIndex <> ButtonIndex) or (PrevState <> State) then
Paint;
PrevButtonIndex := ButtonIndex;
PrevState := State;
end;
procedure TStarRatingControl.SwapBuffers;
begin
BitBlt(Canvas.Handle,
0,
0,
Width,
Height,
FBuffer.Canvas.Handle,
0,
0,
SRCCOPY);
end;
procedure TStarRatingControl.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_SIZE:
begin
FBuffer.SetSize(Width, Height);
Paint;
end;
end;
end;
end.
Just adjust the properties NumStars, Rating, and Spacing, and have fun!
Of course, you could also write a component that uses custom bitmaps instead of the native Windows radio buttons.
Making radio buttons that look like radio buttons but behave differently would confuse the user. Also, you would end up needing half-check marks when you decide to display existing ratings. So something like a progress bar (maybe custom-colored or custom-drawn) to display, how "complete" user satisfaction is could be a better option.
I agree with Eugene and Craig that something like stars would be better, but, to answer the question posed:
The unthemed radio button images are available by calling LoadBitmap with OBM_CHECKBOXES. You can assign that directly to a TBitmap's Handle property, and then divide the width by 4 and the height by 3 to get the subbitmap measurements. Use TCanvas.BrushCopy to do the drawing.
To draw the themed images you need to use Delphi's Themes.pas. Specifically call ThemeServices.GetElementDetails with tbRadioButtonUncheckedNormal or tbRadioButtonCheckedNormal and pass the result to ThemeServices.DrawElement along with the client rect.
Here's a simple override that makes a TCheckBox draw as a checked radio button so you can see how it works:
TCheckBox = class(StdCtrls.TCheckBox)
constructor Create(AOwner: TComponent); override;
procedure PaintWindow(DC: HDC); override;
end;
constructor TCheckBox.Create(AOwner: TComponent);
begin
inherited;
ControlState := ControlState + [csCustomPaint];
end;
procedure TCheckBox.PaintWindow(DC: HDC);
begin
ThemeServices.DrawElement(DC,
ThemeServices.GetElementDetails(tbRadioButtonCheckedNormal), ClientRect);
end;
You could place each radiobutton on a separate (tiny) panel, and that would make a substitute for the missing GroupIndex property.
Maybe not the nicest method, still relatively cheap, it seems to me.
Good inspiration gave you Andreas Rejbrand (+1). I'll provide you just some small piece of code of what you are probably looking for. It's form with two overlapped images with one common event - OnMouseDown. It contains just some mad formula - unfortunately with constants, which I've made some time ago. But sorry I'm not mathematician, so please be patient with me and let's take this also as the inspiration :)

Custom Control Creation in Delphi

I used this on a form and created it like 10 times. That was ok, until I tried to pass this number. Then it started eating system resources. Is there any way I could create a component like this? It is for a Simulator project, 8bits needed to indicate the value of the register in binary.
any help, comments, ideas are really appreciated.
ty.
I was slightly bored, and I wanted to play with my new Delphi XE, so I've made a component for you. It should work in older Delphi's just fine.
You can download it here: BitEditSample.zip
How does it work?
It inherits from customcontrol, so you can focus the component.
It contains an array of labels and checkboxes.
The bit number is stored in the "tag" property of each checkbox
Each checkbox gets an onchange handler that reads the tag, to see which bit needs to be manipulated.
How to use it
It has a property "value". If you change it, the checkboxes will update.
If you click the checkboxes, the value will change.
Set the property "caption" to change the text that says "Register X:"
You can create an "onchange" event handler, so that when the value changes (because of a mouseclick for example), you'll be notified.
The zipfile contains a component, a package, and a sample application (including a compiled exe, so you can try it out quickly).
unit BitEdit;
interface
uses
SysUtils, Classes, Controls, StdCtrls, ExtCtrls;
type
TBitEdit = class(TCustomControl)
private
FValue : Byte; // store the byte value internally
FBitLabels : Array[0..7] of TLabel; // the 7 6 5 4 3 2 1 0 labels
FBitCheckboxes : Array[0..7] of TCheckBox;
FCaptionLabel : TLabel;
FOnChange : TNotifyEvent;
function GetValue: byte;
procedure SetValue(const aValue: byte);
procedure SetCaption(const aValue: TCaption);
procedure SetOnChange(const aValue: TNotifyEvent);
function GetCaption: TCaption;
{ Private declarations }
protected
{ Protected declarations }
procedure DoBitCheckboxClick(Sender:TObject);
procedure UpdateGUI;
procedure DoOnChange;
public
constructor Create(AOwner: TComponent); override;
{ Public declarations }
published
property Value:byte read GetValue write SetValue;
property Caption:TCaption read GetCaption write SetCaption;
property OnChange:TNotifyEvent read FOnChange write SetOnChange;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TBitEdit]);
end;
{ TBitEdit }
constructor TBitEdit.Create(AOwner: TComponent);
var
I:Integer;
begin
inherited;
Width := 193;
Height := 33;
FCaptionLabel := TLabel.Create(self);
FCaptionLabel.Left := 0;
FCaptionLabel.Top := 10;
FCaptionLabel.Caption := 'Register X :';
FCaptionLabel.Width := 60;
FCaptionLabel.Parent := self;
FCaptionLabel.Show;
for I := 0 to 7 do
begin
FBitCheckboxes[I] := TCheckBox.Create(self);
FBitCheckboxes[I].Parent := self;
FBitCheckboxes[I].Left := 5 + FCaptionLabel.Width + (16 * I);
FBitCheckboxes[I].Top := 14;
FBitCheckboxes[I].Caption := '';
FBitCheckboxes[I].Tag := 7-I;
FBitCheckboxes[I].Hint := 'bit ' + IntToStr(FBitCheckboxes[I].Tag);
FBitCheckboxes[I].OnClick := DoBitCheckboxClick;
end;
for I := 0 to 7 do
begin
FBitLabels[I] := TLabel.Create(Self);
FBitLabels[I].Parent := self;
FBitLabels[I].Left := 8 + FCaptionLabel.Width + (16 * I);
FBitLabels[I].Top := 0;
FBitLabels[I].Caption := '';
FBitLabels[I].Tag := 7-I;
FBitLabels[I].Hint := 'bit ' + IntToStr(FBitLabels[I].Tag);
FBitLabels[I].Caption := IntToStr(FBitLabels[I].Tag);
FBitLabels[I].OnClick := DoBitCheckboxClick;
end;
end;
procedure TBitEdit.DoBitCheckboxClick(Sender: TObject);
var
LCheckbox:TCheckbox;
FOldValue:Byte;
begin
if not (Sender is TCheckBox) then
Exit;
FOldValue := FValue;
LCheckbox := Sender as TCheckbox;
FValue := FValue XOR (1 shl LCheckbox.Tag);
if FOldValue <> FValue then
DoOnChange;
end;
procedure TBitEdit.DoOnChange;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
function TBitEdit.GetCaption: TCaption;
begin
Result := FCaptionLabel.Caption;
end;
function TBitEdit.GetValue: byte;
begin
Result := FValue;
end;
procedure TBitEdit.SetCaption(const aValue: TCaption);
begin
FCaptionLabel.Caption := aValue;
end;
procedure TBitEdit.SetOnChange(const aValue: TNotifyEvent);
begin
FOnChange := aValue;
end;
procedure TBitEdit.SetValue(const aValue: byte);
begin
if aValue=FValue then
Exit;
FValue := aValue;
DoOnChange;
UpdateGUI;
end;
procedure TBitEdit.UpdateGUI;
var
I:Integer;
begin
for I := 0 to 7 do
FBitCheckboxes[I].Checked := FValue shr FBitCheckboxes[I].Tag mod 2 = 1;
end;
end.
Resources
I guess the problem that the OP was facing is a feedback loop, where two event handlers call each other.
Other resources don't seem to increase in an unusual way when using more bit editors. I've tested it with an application with many instances of the bit edit component:
[MANY] | [1]
-------------------------+--------------
#Handles |
User : 314 | 35
GDI : 57 | 57
System : 385 | 385
#Memory |
Physical : 8264K | 7740K
Virtual : 3500K | 3482K
#CPU |
Kernel time: 0:00:00.468 | 0:00:00.125
User time : 0:00:00.109 | 0:00:00.062
I agree that there shouldn't be a problem with a hundred checkboxes on a form. But for fun's sake, I just wrote a component that does all drawing manually, so there is only one window handle per control (that is, per eight checkboxes). My control works both with visual themes enabled and with themes disabled. It is also double-buffered, and completely flicker-free.
unit ByteEditor;
interface
uses
Windows, SysUtils, Classes, Messages, Controls, Graphics, Themes, UxTheme;
type
TWinControlCracker = class(TWinControl); // because necessary method SelectNext is protected...
TByteEditor = class(TCustomControl)
private
{ Private declarations }
FTextLabel: TCaption;
FBuffer: TBitmap;
FValue: byte;
CheckboxRect: array[0..7] of TRect;
LabelRect: array[0..7] of TRect;
FSpacing: integer;
FVerticalSpacing: integer;
FLabelSpacing: integer;
FLabelWidth, FLabelHeight: integer;
FShowHex: boolean;
FHexPrefix: string;
FMouseHoverIndex: integer;
FKeyboardFocusIndex: integer;
FOnChange: TNotifyEvent;
FManualLabelWidth: integer;
FAutoLabelSize: boolean;
FLabelAlignment: TAlignment;
procedure SetTextLabel(const TextLabel: TCaption);
procedure SetValue(const Value: byte);
procedure SetSpacing(const Spacing: integer);
procedure SetVerticalSpacing(const VerticalSpacing: integer);
procedure SetLabelSpacing(const LabelSpacing: integer);
procedure SetShowHex(const ShowHex: boolean);
procedure SetHexPrefix(const HexPrefix: string);
procedure SetManualLabelWidth(const ManualLabelWidth: integer);
procedure SetAutoLabelSize(const AutoLabelSize: boolean);
procedure SetLabelAlignment(const LabelAlignment: TAlignment);
procedure UpdateMetrics;
protected
{ Protected declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure WndProc(var Msg: TMessage); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
public
{ Public declarations }
published
{ Published declarations }
property Color;
property LabelAlignment: TAlignment read FLabelAlignment write SetLabelAlignment default taRightJustify;
property AutoLabelSize: boolean read FAutoLabelSize write SetAutoLabelSize default true;
property ManualLabelWidth: integer read FManualLabelWidth write SetManualLabelWidth default 64;
property TextLabel: TCaption read FTextLabel write SetTextLabel;
property Value: byte read FValue write SetValue default 0;
property Spacing: integer read FSpacing write SetSpacing default 3;
property VerticalSpacing: integer read FVerticalSpacing write SetVerticalSpacing default 3;
property LabelSpacing: integer read FLabelSpacing write SetLabelSpacing default 8;
property ShowHex: boolean read FShowHex write SetShowHex default false;
property HexPrefix: string read FHexPrefix write SetHexPrefix;
property TabOrder;
property TabStop;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register;
implementation
const
PowersOfTwo: array[0..7] of byte = (1, 2, 4, 8, 16, 32, 64, 128); // PowersOfTwo[n] := 2^n
BasicCheckbox: TThemedElementDetails = (Element: teButton; Part: BP_CHECKBOX; State: CBS_UNCHECKEDNORMAL);
procedure Register;
begin
RegisterComponents('Rejbrand 2009', [TByteEditor]);
end;
function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
IsIntInInterval := (xmin <= x) and (x <= xmax);
end;
function PointInRect(const Point: TPoint; const Rect: TRect): boolean; inline;
begin
PointInRect := IsIntInInterval(Point.X, Rect.Left, Rect.Right) and
IsIntInInterval(Point.Y, Rect.Top, Rect.Bottom);
end;
function GrowRect(const Rect: TRect): TRect;
begin
result.Left := Rect.Left - 1;
result.Top := Rect.Top - 1;
result.Right := Rect.Right + 1;
result.Bottom := Rect.Bottom + 1;
end;
{ TByteEditor }
constructor TByteEditor.Create(AOwner: TComponent);
begin
inherited;
FLabelAlignment := taRightJustify;
FManualLabelWidth := 64;
FAutoLabelSize := true;
FTextLabel := 'Register:';
FValue := 0;
FSpacing := 3;
FVerticalSpacing := 3;
FLabelSpacing := 8;
FMouseHoverIndex := -1;
FKeyboardFocusIndex := 7;
FHexPrefix := '$';
FShowHex := false;
FBuffer := TBitmap.Create;
end;
destructor TByteEditor.Destroy;
begin
FBuffer.Free;
inherited;
end;
procedure TByteEditor.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_TAB:
if TabStop then
begin
if ssShift in Shift then
if FKeyboardFocusIndex = 7 then
TWinControlCracker(Parent).SelectNext(Self, false, true)
else
inc(FKeyboardFocusIndex)
else
if FKeyboardFocusIndex = 0 then
TWinControlCracker(Parent).SelectNext(Self, true, true)
else
dec(FKeyboardFocusIndex);
Paint;
end;
VK_SPACE:
SetValue(FValue xor PowersOfTwo[FKeyboardFocusIndex]);
end;
end;
procedure TByteEditor.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited;
end;
procedure TByteEditor.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if TabStop then SetFocus;
FKeyboardFocusIndex := FMouseHoverIndex;
Paint;
end;
procedure TByteEditor.MouseMove(Shift: TShiftState; X, Y: Integer);
var
i: Integer;
OldIndex: integer;
begin
inherited;
OldIndex := FMouseHoverIndex;
FMouseHoverIndex := -1;
for i := 0 to 7 do
if PointInRect(point(X, Y), CheckboxRect[i]) then
begin
FMouseHoverIndex := i;
break;
end;
if FMouseHoverIndex <> OldIndex then
Paint;
end;
procedure TByteEditor.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
Paint;
if (FMouseHoverIndex <> -1) and (Button = mbLeft) then
begin
SetValue(FValue xor PowersOfTwo[FMouseHoverIndex]);
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
const
DTAlign: array[TAlignment] of cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);
procedure TByteEditor.Paint;
var
details: TThemedElementDetails;
i: Integer;
TextRect: TRect;
HexStr: string;
begin
inherited;
FBuffer.Canvas.Brush.Color := Color;
FBuffer.Canvas.FillRect(ClientRect);
TextRect := Rect(0, 0, FLabelWidth, Height);
DrawText(FBuffer.Canvas.Handle, FTextLabel, length(FTextLabel), TextRect,
DT_SINGLELINE or DT_VCENTER or DTAlign[FLabelAlignment] or DT_NOCLIP);
for i := 0 to 7 do
begin
if ThemeServices.ThemesEnabled then
with details do
begin
Element := teButton;
Part := BP_CHECKBOX;
if FMouseHoverIndex = i then
if csLButtonDown in ControlState then
if FValue and PowersOfTwo[i] <> 0 then
State := CBS_CHECKEDPRESSED
else
State := CBS_UNCHECKEDPRESSED
else
if FValue and PowersOfTwo[i] <> 0 then
State := CBS_CHECKEDHOT
else
State := CBS_UNCHECKEDHOT
else
if FValue and PowersOfTwo[i] <> 0 then
State := CBS_CHECKEDNORMAL
else
State := CBS_UNCHECKEDNORMAL;
ThemeServices.DrawElement(FBuffer.Canvas.Handle, details, CheckboxRect[i]);
end
else
begin
if FMouseHoverIndex = i then
if csLButtonDown in ControlState then
if FValue and PowersOfTwo[i] <> 0 then
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_PUSHED)
else
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_PUSHED)
else
if FValue and PowersOfTwo[i] <> 0 then
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_HOT)
else
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_HOT)
else
if FValue and PowersOfTwo[i] <> 0 then
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED)
else
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK)
end;
TextRect := LabelRect[i];
DrawText(FBuffer.Canvas.Handle, IntToStr(i), 1, TextRect, DT_SINGLELINE or DT_TOP or DT_CENTER or DT_NOCLIP);
end;
if Focused then
DrawFocusRect(FBuffer.Canvas.Handle, GrowRect(CheckboxRect[FKeyboardFocusIndex]));
if FShowHex then
begin
TextRect.Left := CheckboxRect[7].Left;
TextRect.Right := CheckboxRect[0].Right;
TextRect.Top := CheckboxRect[7].Bottom + FVerticalSpacing;
TextRect.Bottom := TextRect.Top + FLabelHeight;
HexStr := 'Value = ' + IntToStr(FValue) + ' (' + FHexPrefix + IntToHex(FValue, 2) + ')';
DrawText(FBuffer.Canvas.Handle, HexStr, length(HexStr), TextRect,
DT_SINGLELINE or DT_CENTER or DT_NOCLIP);
end;
BitBlt(Canvas.Handle, 0, 0, Width, Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TByteEditor.SetShowHex(const ShowHex: boolean);
begin
if ShowHex <> FShowHex then
begin
FShowHex := ShowHex;
Paint;
end;
end;
procedure TByteEditor.SetSpacing(const Spacing: integer);
begin
if Spacing <> FSpacing then
begin
FSpacing := Spacing;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetVerticalSpacing(const VerticalSpacing: integer);
begin
if VerticalSpacing <> FVerticalSpacing then
begin
FVerticalSpacing := VerticalSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetAutoLabelSize(const AutoLabelSize: boolean);
begin
if FAutoLabelSize <> AutoLabelSize then
begin
FAutoLabelSize := AutoLabelSize;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetHexPrefix(const HexPrefix: string);
begin
if not SameStr(FHexPrefix, HexPrefix) then
begin
FHexPrefix := HexPrefix;
Paint;
end;
end;
procedure TByteEditor.SetLabelAlignment(const LabelAlignment: TAlignment);
begin
if FLabelAlignment <> LabelAlignment then
begin
FLabelAlignment := LabelAlignment;
Paint;
end;
end;
procedure TByteEditor.SetLabelSpacing(const LabelSpacing: integer);
begin
if LabelSpacing <> FLabelSpacing then
begin
FLabelSpacing := LabelSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetManualLabelWidth(const ManualLabelWidth: integer);
begin
if FManualLabelWidth <> ManualLabelWidth then
begin
FManualLabelWidth := ManualLabelWidth;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetTextLabel(const TextLabel: TCaption);
begin
if not SameStr(TextLabel, FTextLabel) then
begin
FTextLabel := TextLabel;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetValue(const Value: byte);
begin
if Value <> FValue then
begin
FValue := Value;
Paint;
end;
end;
procedure TByteEditor.WndProc(var Msg: TMessage);
begin
inherited;
case Msg.Msg of
WM_GETDLGCODE:
Msg.Result := Msg.Result or DLGC_WANTTAB or DLGC_WANTARROWS or DLGC_WANTALLKEYS;
WM_ERASEBKGND:
Msg.Result := 1;
WM_SIZE:
begin
UpdateMetrics;
Paint;
end;
WM_SETFOCUS, WM_KILLFOCUS:
Paint;
end;
end;
procedure TByteEditor.UpdateMetrics;
var
CheckboxWidth, CheckboxHeight: integer;
i: Integer;
begin
FBuffer.SetSize(Width, Height);
FBuffer.Canvas.Font.Assign(Font);
with FBuffer.Canvas.TextExtent(FTextLabel) do
begin
if FAutoLabeLSize then
FLabelWidth := cx
else
FLabelWidth := FManualLabelWidth;
FLabelHeight := cy;
end;
CheckboxWidth := GetSystemMetrics(SM_CXMENUCHECK);
CheckboxHeight := GetSystemMetrics(SM_CYMENUCHECK);
for i := 0 to 7 do
begin
with CheckboxRect[i] do
begin
Left := (FLabelWidth + FLabelSpacing) + (7-i) * (CheckboxWidth + FSpacing);
Right := Left + CheckboxWidth;
Top := (Height - (CheckboxHeight)) div 2;
Bottom := Top + CheckboxHeight;
end;
LabelRect[i].Left := CheckboxRect[i].Left;
LabelRect[i].Right := CheckboxRect[i].Right;
LabelRect[i].Top := CheckboxRect[i].Top - FLabelHeight - FVerticalSpacing;
LabelRect[i].Bottom := CheckboxRect[i].Top;
end;
Width := (FLabelWidth + FLabelSpacing) + 8 * (CheckboxWidth + FSpacing);
end;
end.
Example:
(High-Res)
You have these options, in order of difficulty:
Create a frame, and reuse it
Create a compound control (using
maybe a panel, labels and
checkboxes). Each control will
handle its own keyboard/mouse
interaction.
Create a whole new control - all
elements are drawn using the proper
APIs and all keyboard/mouse
interaction is handled by the
control code.

Resources