Rounded and titled "TPanel" in Delphi 7 - delphi

I would have a TPanel in my application but with another look.
For it I want a colored title bar and the up corner rounded just like in some user interfaces like it
Do you know any component or library for it ? (Prefered Open source but not only).
I tried TJVCaptionPanel it's OK but needs rounded up corner.

Like this?
unit CustomCaptionPanel;
interface
uses
Windows, SysUtils, Classes, Controls, Graphics;
type
TCustomCaptionPanel = class(TCustomControl)
private const
DEFAULT_BORDER_COLOR = $0033CCFF;
DEFAULT_CLIENT_COLOR = clWindow;
DEFAULT_BORDER_RADIUS = 16;
private
{ Private declarations }
FBorderColor: TColor;
FClientColor: TColor;
FBorderRadius: integer;
FCaption: TCaption;
FAlignment: TAlignment;
procedure SetBorderColor(BorderColor: TColor);
procedure SetClientColor(ClientColor: TColor);
procedure SetBorderRadius(BorderRadius: integer);
procedure SetCaption(const Caption: TCaption);
procedure SetAlignment(Alignment: TAlignment);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property Color;
property Caption read FCaption write SetCaption;
property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
property Font;
property BorderColor: TColor read FBorderColor write SetBorderColor default DEFAULT_BORDER_COLOR;
property ClientColor: TColor read FClientColor write SetClientColor default DEFAULT_CLIENT_COLOR;
property BorderRadius: integer read FBorderRadius write SetBorderRadius default DEFAULT_BORDER_RADIUS;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Rejbrand 2009', [TCustomCaptionPanel]);
end;
{ TCustomCaptionPanel }
constructor TCustomCaptionPanel.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csDoubleClicks, csReplicatable, csPannable];
FBorderColor := DEFAULT_BORDER_COLOR;
FClientColor := DEFAULT_CLIENT_COLOR;
FBorderRadius := DEFAULT_BORDER_RADIUS;
FAlignment := taCenter;
end;
procedure TCustomCaptionPanel.Paint;
var
r: TRect;
const
Alignments: array[TAlignment] of integer = (DT_LEFT, DT_RIGHT, DT_CENTER);
begin
inherited;
Canvas.Pen.Color := FBorderColor;
Canvas.Brush.Color := FBorderColor;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(FBorderRadius,
0,
ClientWidth - FBorderRadius,
FBorderRadius));
Canvas.Ellipse(Rect(0,
0,
2*FBorderRadius,
2*FBorderRadius));
Canvas.Ellipse(Rect(ClientWidth - 2*FBorderRadius,
0,
ClientWidth,
2*FBorderRadius));
Canvas.Brush.Color := FClientColor;
Canvas.Rectangle(Rect(0,
FBorderRadius,
ClientWidth,
ClientHeight));
Canvas.Font.Assign(Self.Font);
r := Rect(FBorderRadius, 0, ClientWidth - FBorderRadius, FBorderRadius);
Canvas.Brush.Style := bsClear;
DrawText(Canvas.Handle,
PChar(Caption),
length(Caption),
r,
DT_SINGLELINE or DT_LEFT or DT_VCENTER or DT_END_ELLIPSIS or Alignments[FAlignment]);
end;
procedure TCustomCaptionPanel.SetAlignment(Alignment: TAlignment);
begin
if FAlignment <> Alignment then
begin
FAlignment := Alignment;
Invalidate;
end;
end;
procedure TCustomCaptionPanel.SetBorderColor(BorderColor: TColor);
begin
if FBorderColor <> BorderColor then
begin
FBorderColor := BorderColor;
Invalidate;
end;
end;
procedure TCustomCaptionPanel.SetBorderRadius(BorderRadius: integer);
begin
if FBorderRadius <> BorderRadius then
begin
FBorderRadius := BorderRadius;
Invalidate;
end;
end;
procedure TCustomCaptionPanel.SetCaption(const Caption: TCaption);
begin
if not SameStr(FCaption, Caption) then
begin
FCaption := Caption;
Invalidate;
end;
end;
procedure TCustomCaptionPanel.SetClientColor(ClientColor: TColor);
begin
if FClientColor <> ClientColor then
begin
FClientColor := ClientColor;
Invalidate;
end;
end;
end.

If you wanna round the corner of anything you want, try this:
procedure RoundCornerOf(Control: TWinControl) ;
var
R: TRect;
Rgn: HRGN;
begin
with Control do
begin
R := ClientRect;
rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20) ;
Perform(EM_GETRECT, 0, lParam(#r)) ;
InflateRect(r, - 4, - 4) ;
Perform(EM_SETRECTNP, 0, lParam(#r)) ;
SetWindowRgn(Handle, rgn, True) ;
Invalidate;
end;
end;

Related

How to make custom BitBtn?

How to make custom BitBtn with color property?
I have found one solution here, but it is a TButton not TBitBtn so I have edited the code as follows :
unit ColorBitBtn;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Buttons, ExtCtrls;
type
TColorBitBtn = class(TBitBtn)
private
ShowBackColor : Boolean;
FCanvas : TCanvas;
IsFocused : Boolean;
FBackColor : TColor;
FForeColor : TColor;
FHoverColor : TColor;
procedure SetBackColor(const Value: TColor);
procedure SetForeColor(const Value: TColor);
procedure SetHoverColor(const Value: TColor);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WndProc(var Message : TMessage); override;
procedure SetBitBtnStyle(Value: Boolean);
procedure DrawBitBtn(Rect: TRect; State: UINT);
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property BackColor : TColor read FBackColor write SetBackColor default clBtnFace;
property ForeColor : TColor read FForeColor write SetForeColor default clBtnText;
property HoverColor: TColor read FHoverColor write SetHoverColor default clBtnFace;
end;
procedure Register;
implementation
constructor TColorBitBtn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ShowBackColor := True;
FCanvas := TCanvas.Create;
BackColor := clBtnFace;
ForeColor := clBtnText;
HoverColor := clBtnFace;
end;
destructor TColorBitBtn.Destroy;
begin
FreeAndNil(FCanvas);
inherited Destroy;
end;
procedure TColorBitBtn.WndProc(var Message : TMessage);
begin
if (Message.Msg = CM_MOUSELEAVE) then
begin
ShowBackColor := True;
Invalidate;
end;
if (Message.Msg = CM_MOUSEENTER) then
begin
ShowBackColor := False;
Invalidate;
end;
inherited;
end;
procedure TColorBitBtn.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := Style or BS_OWNERDRAW;
end;
procedure TColorBitBtn.SetBitBtnStyle(Value: Boolean);
begin
if Value <> IsFocused then
begin
IsFocused := Value;
Invalidate;
end;
end;
procedure TColorBitBtn.CNMeasureItem(var Message: TWMMeasureItem);
begin
with Message.MeasureItemStruct^ do
begin
itemWidth := Width;
itemHeight := Height;
end;
end;
procedure TColorBitBtn.CNDrawItem(var Message: TWMDrawItem);
var
SaveIndex: Integer;
begin
with Message.DrawItemStruct^ do
begin
SaveIndex := SaveDC(hDC);
FCanvas.Lock;
try
FCanvas.Handle := hDC;
FCanvas.Font := Font;
FCanvas.Brush := Brush;
DrawBitBtn(rcItem, itemState);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
RestoreDC(hDC, SaveIndex);
end;
end;
Message.Result := 1;
end;
procedure TColorBitBtn.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TColorBitBtn.CMFontChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TColorBitBtn.SetBackColor(const Value: TColor);
begin
if FBackColor <> Value then
begin
FBackColor:= Value;
Invalidate;
end;
end;
procedure TColorBitBtn.SetForeColor(const Value: TColor);
begin
if FForeColor <> Value then
begin
FForeColor:= Value;
Invalidate;
end;
end;
procedure TColorBitBtn.SetHoverColor(const Value: TColor);
begin
if FHoverColor <> Value then
begin
FHoverColor:= Value;
Invalidate;
end;
end;
procedure TColorBitBtn.DrawBitBtn(Rect: TRect; State: UINT);
var Flags, OldMode: Longint;
IsDown, IsDefault, IsDisabled: Boolean;
OldColor: TColor;
OrgRect: TRect;
NewCaption : string;
begin
NewCaption := Caption;
OrgRect := Rect;
Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
IsDown := State and ODS_SELECTED <> 0;
IsDisabled := State and ODS_DISABLED <> 0;
IsDefault := State and ODS_FOCUS <> 0;
if IsDown then Flags := Flags or DFCS_PUSHED;
if IsDisabled then Flags := Flags or DFCS_INACTIVE;
if (IsFocused or IsDefault) then
begin
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Style := bsClear;
FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, - 1, - 1);
end;
if IsDown then
begin
FCanvas.Pen.Color := clBtnShadow;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Color := clBtnFace;
FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, - 1, - 1);
end
else
begin
DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);
end;
if IsDown then OffsetRect(Rect, 1, 1);
OldColor := FCanvas.Brush.Color;
if ShowBackColor then
FCanvas.Brush.Color := BackColor
else
FCanvas.Brush.Color := HoverColor;
FCanvas.FillRect(Rect);
FCanvas.Brush.Color := OldColor;
OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);
FCanvas.Font.Color := ForeColor;
if IsDisabled then
DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(NewCaption), 0,
((Rect.Right - Rect.Left) - FCanvas.TextWidth(NewCaption)) div 2,
((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(NewCaption)) div 2,
0, 0, DST_TEXT or DSS_DISABLED)
else
begin
InflateRect(Rect, -4, -4);
DrawText(FCanvas.Handle, PChar(NewCaption), - 1, Rect, DT_WORDBREAK or DT_CENTER);
end;
SetBkMode(FCanvas.Handle, OldMode);
if (IsFocused and IsDefault) then
begin
Rect := OrgRect;
InflateRect(Rect, - 4, - 4);
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Brush.Color := clBtnFace;
DrawFocusRect(FCanvas.Handle, Rect);
end;
end;
procedure Register;
begin
RegisterComponents('Standard', [TColorBitBtn]);
end;
initialization
RegisterClass(TColorBitBtn); // needed for persistence at runtime
end.
After doing the same. it compiles perfectly without any error. But the Font.Color does not get changed on any event like OnClick, OnMouseDown etc and another problem is not look like Button or BitBtn after enabling Theme Manifest like the following picture
Here the first is Standard Button, Standard BitBtn followed by Custom BitBtn created by the above code after adding Theme Manifest.

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.

Change border color of GroupBox in Delphi

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.

Delphi: Changing the Button Color using a Class Helper

I need to change the visual style of my delphi form controls inorder to show them from a .Net environment. To do this, I need to change the colors of delphi controls to blue ($00FCF5EE). I have used "TButton" controls widely which doesn't have a "Color" property.So, instead of changing the buttons to speed buttons, I have tried a different approach by introducing a parent form and inheriting all the other forms from this parent form. In the parent form, I have a class helper to change the color of buttons. Here is the code: (I am using Delphi 2007)
TButtonHelper=class helper for TButton
private
procedure doChangeColor;
public
procedure DrawChangeColor;
end;
TParentForm = class(TForm)
public
procedure AfterConstruction; override;
end;
And in the implementation section, I have
procedure TButtonHelper.doChangeColor;
var
SaveIndex: Integer;
FCanvas:TCanvas;
rect:TRect;
begin
if csDestroying in ComponentState then exit;
FCanvas:=TCanvas.Create;
SaveIndex := SaveDC(Self.Handle);
FCanvas.Lock;
try
FCanvas.Handle := Handle;
FCanvas.Font := Font;
FCanvas.Brush := self.Brush;
FCanvas.Brush.Color:=$00FCF5EE;
FCanvas.FillRect(BoundsRect);//Omitting the code to draw the text
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
RestoreDC(handle, SaveIndex);
FCanvas.Free;
end;
end;
procedure TButtonHelper.DrawChangeColor;
begin
doChangeColor;
self.Repaint;
end;
procedure TParentForm.AfterConstruction;
var
i : Integer;
wc: TControl;
begin
inherited;
for i := 0 to self.ControlCount - 1 do begin
wc:=Controls[i];
if wc is TButton then
TButton(wc).DrawChangeColor;
end;
end;
But this doesn't work. Although the doChangeColor method is executed, it is not changing the color of the button.Please let me know what I am missing here.
Thanking you all,
Pradeep
here's a class that adds color properties to the standard TButton:
unit u_class_colorbutton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Buttons, ExtCtrls;
type
TColorButton = class(TButton)
private
ShowBackColor : Boolean;
FCanvas : TCanvas;
IsFocused : Boolean;
FBackColor : TColor;
FForeColor : TColor;
FHoverColor : TColor;
procedure SetBackColor(const Value: TColor);
procedure SetForeColor(const Value: TColor);
procedure SetHoverColor(const Value: TColor);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WndProc(var Message : TMessage); override;
procedure SetButtonStyle(Value: Boolean); override;
procedure DrawButton(Rect: TRect; State: UINT);
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property BackColor : TColor read FBackColor write SetBackColor default clBtnFace;
property ForeColor : TColor read FForeColor write SetForeColor default clBtnText;
property HoverColor: TColor read FHoverColor write SetHoverColor default clBtnFace;
end;
procedure Register;
implementation
constructor TColorButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ShowBackColor := True;
FCanvas := TCanvas.Create;
BackColor := clBtnFace;
ForeColor := clBtnText;
HoverColor := clBtnFace;
end;
destructor TColorButton.Destroy;
begin
FreeAndNil(FCanvas);
inherited Destroy;
end;
procedure TColorButton.WndProc(var Message : TMessage);
begin
if (Message.Msg = CM_MOUSELEAVE) then
begin
ShowBackColor := True;
Invalidate;
end;
if (Message.Msg = CM_MOUSEENTER) then
begin
ShowBackColor := False;
Invalidate;
end;
inherited;
end;
procedure TColorButton.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := Style or BS_OWNERDRAW;
end;
procedure TColorButton.SetButtonStyle(Value: Boolean);
begin
if Value <> IsFocused then
begin
IsFocused := Value;
Invalidate;
end;
end;
procedure TColorButton.CNMeasureItem(var Message: TWMMeasureItem);
begin
with Message.MeasureItemStruct^ do
begin
itemWidth := Width;
itemHeight := Height;
end;
end;
procedure TColorButton.CNDrawItem(var Message: TWMDrawItem);
var
SaveIndex: Integer;
begin
with Message.DrawItemStruct^ do
begin
SaveIndex := SaveDC(hDC);
FCanvas.Lock;
try
FCanvas.Handle := hDC;
FCanvas.Font := Font;
FCanvas.Brush := Brush;
DrawButton(rcItem, itemState);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
RestoreDC(hDC, SaveIndex);
end;
end;
Message.Result := 1;
end;
procedure TColorButton.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TColorButton.CMFontChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TColorButton.SetBackColor(const Value: TColor);
begin
if FBackColor <> Value then
begin
FBackColor:= Value;
Invalidate;
end;
end;
procedure TColorButton.SetForeColor(const Value: TColor);
begin
if FForeColor <> Value then
begin
FForeColor:= Value;
Invalidate;
end;
end;
procedure TColorButton.SetHoverColor(const Value: TColor);
begin
if FHoverColor <> Value then
begin
FHoverColor:= Value;
Invalidate;
end;
end;
procedure TColorButton.DrawButton(Rect: TRect; State: UINT);
var Flags, OldMode: Longint;
IsDown, IsDefault, IsDisabled: Boolean;
OldColor: TColor;
OrgRect: TRect;
NewCaption : string;
begin
NewCaption := Caption;
OrgRect := Rect;
Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
IsDown := State and ODS_SELECTED <> 0;
IsDisabled := State and ODS_DISABLED <> 0;
IsDefault := State and ODS_FOCUS <> 0;
if IsDown then Flags := Flags or DFCS_PUSHED;
if IsDisabled then Flags := Flags or DFCS_INACTIVE;
if (IsFocused or IsDefault) then
begin
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Style := bsClear;
FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, - 1, - 1);
end;
if IsDown then
begin
FCanvas.Pen.Color := clBtnShadow;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Color := clBtnFace;
FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, - 1, - 1);
end
else
begin
DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);
end;
if IsDown then OffsetRect(Rect, 1, 1);
OldColor := FCanvas.Brush.Color;
if ShowBackColor then
FCanvas.Brush.Color := BackColor
else
FCanvas.Brush.Color := HoverColor;
FCanvas.FillRect(Rect);
FCanvas.Brush.Color := OldColor;
OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);
FCanvas.Font.Color := ForeColor;
if IsDisabled then
DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(NewCaption), 0,
((Rect.Right - Rect.Left) - FCanvas.TextWidth(NewCaption)) div 2,
((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(NewCaption)) div 2,
0, 0, DST_TEXT or DSS_DISABLED)
else
begin
InflateRect(Rect, -4, -4);
DrawText(FCanvas.Handle, PChar(NewCaption), - 1, Rect, DT_WORDBREAK or DT_CENTER);
end;
SetBkMode(FCanvas.Handle, OldMode);
if (IsFocused and IsDefault) then
begin
Rect := OrgRect;
InflateRect(Rect, - 4, - 4);
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Brush.Color := clBtnFace;
DrawFocusRect(FCanvas.Handle, Rect);
end;
end;
procedure Register;
begin
RegisterComponents('Standard', [TColorButton]);
end;
initialization
RegisterClass(TColorButton); // needed for persistence at runtime
end.
You can hack it into your application easily:
find/replace all TButton references to TColorButton
inside your .pas and .dfm files.
You can set separate colors for background, font and hovering.
If you want add styling application wide, maybe it is better to create a GUI with a library that has native support like DevExpress, TMS, ...
Personally, I like DevExpress the most but that's a matter of personal taste.

Delphi windows 7 control panel component

Im looking for a delphi component that looks and functions like the Windows 7 control panel buttons when you "view by category". Anybody know if something like this already exists?
I just created a small component that looks sort of what you want. It is double-buffered, and hence completely flicker-free, and works both with visual themes enabled and disabled.
unit TaskButton;
interface
uses
SysUtils, Forms, Messages, Windows, Graphics, Classes, Controls, UxTheme,
ImgList, PNGImage;
type
TIconSource = (isImageList, isPNGImage);
TTaskButtonLinkClickEvent = procedure(Sender: TObject; LinkIndex: integer) of object;
TTaskButton = class(TCustomControl)
private
{ Private declarations }
FCaption: TCaption;
FHeaderRect: TRect;
FImageSpacing: integer;
FLinks: TStrings;
FHeaderHeight: integer;
FLinkHeight: integer;
FLinkSpacing: integer;
FHeaderSpacing: integer;
FLinkRects: array of TRect;
FPrevMouseHoverIndex: integer;
FMouseHoverIndex: integer;
FImages: TImageList;
FImageIndex: TImageIndex;
FIconSource: TIconSource;
FImage: TPngImage;
FBuffer: TBitmap;
FOnLinkClick: TTaskButtonLinkClickEvent;
procedure UpdateMetrics;
procedure SetCaption(const Caption: TCaption);
procedure SetImageSpacing(ImageSpacing: integer);
procedure SetLinkSpacing(LinkSpacing: integer);
procedure SetHeaderSpacing(HeaderSpacing: integer);
procedure SetLinks(Links: TStrings);
procedure SetImages(Images: TImageList);
procedure SetImageIndex(ImageIndex: TImageIndex);
procedure SetIconSource(IconSource: TIconSource);
procedure SetImage(Image: TPngImage);
procedure SwapBuffers;
function ImageWidth: integer;
function ImageHeight: integer;
procedure SetNonThemedHeaderFont;
procedure SetNonThemedLinkFont(Hovering: boolean = false);
protected
{ Protected declarations }
procedure Paint; override;
procedure WndProc(var Message: 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;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Caption: TCaption read FCaption write SetCaption;
property Links: TStrings read FLinks write SetLinks;
property ImageSpacing: integer read FImageSpacing write SetImageSpacing default 16;
property HeaderSpacing: integer read FHeaderSpacing write SetHeaderSpacing default 2;
property LinkSpacing: integer read FLinkSpacing write SetLinkSpacing default 2;
property Images: TImageList read FImages write SetImages;
property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;
property Image: TPngImage read FImage write SetImage;
property IconSource: TIconSource read FIconSource write SetIconSource default isPNGImage;
property OnLinkClick: TTaskButtonLinkClickEvent read FOnLinkClick write FOnLinkClick;
end;
procedure Register;
implementation
uses Math;
procedure Register;
begin
RegisterComponents('Rejbrand 2009', [TTaskButton]);
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;
{ TTaskButton }
constructor TTaskButton.Create(AOwner: TComponent);
begin
inherited;
InitThemeLibrary;
FBuffer := TBitmap.Create;
FLinks := TStringList.Create;
FImage := TPngImage.Create;
FImageSpacing := 16;
FHeaderSpacing := 2;
FLinkSpacing := 2;
FPrevMouseHoverIndex := -1;
FMouseHoverIndex := -1;
FIconSource := isPNGImage;
end;
destructor TTaskButton.Destroy;
begin
FLinkRects := nil;
FImage.Free;
FLinks.Free;
FBuffer.Free;
inherited;
end;
function TTaskButton.ImageHeight: integer;
begin
result := 0;
case FIconSource of
isImageList:
if Assigned(FImages) then
result := FImages.Height;
isPNGImage:
if Assigned(FImage) then
result := FImage.Height;
end;
end;
function TTaskButton.ImageWidth: integer;
begin
result := 0;
case FIconSource of
isImageList:
if Assigned(FImages) then
result := FImages.Width;
isPNGImage:
if Assigned(FImage) then
result := FImage.Width;
end;
end;
procedure TTaskButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
Paint;
end;
procedure TTaskButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
i: Integer;
begin
inherited;
FMouseHoverIndex := -1;
for i := 0 to high(FLinkRects) do
if PointInRect(point(X, Y), FLinkRects[i]) then
begin
FMouseHoverIndex := i;
break;
end;
if FMouseHoverIndex <> FPrevMouseHoverIndex then
begin
Cursor := IfThen(FMouseHoverIndex <> -1, crHandPoint, crDefault);
Paint;
end;
FPrevMouseHoverIndex := FMouseHoverIndex;
end;
procedure TTaskButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
Paint;
if (FMouseHoverIndex <> -1) and Assigned(FOnLinkClick) then
FOnLinkClick(Self, FMouseHoverIndex);
end;
procedure TTaskButton.Paint;
var
theme: HTHEME;
i: Integer;
pnt: TPoint;
r: PRect;
begin
inherited;
if FLinks.Count <> length(FLinkRects) then
UpdateMetrics;
FBuffer.Canvas.Brush.Color := Color;
FBuffer.Canvas.FillRect(ClientRect);
if GetCursorPos(pnt) then
if PointInRect(Self.ScreenToClient(pnt), ClientRect) then
begin
if UxTheme.UseThemes then
begin
theme := OpenThemeData(Handle, 'BUTTON');
if theme <> 0 then
try
DrawThemeBackground(theme,
FBuffer.Canvas.Handle,
BP_COMMANDLINK,
CMDLS_HOT,
ClientRect,
nil);
finally
CloseThemeData(theme);
end;
end
else
begin
New(r);
try
r^ := ClientRect;
DrawEdge(FBuffer.Canvas.Handle, r^, EDGE_RAISED, BF_RECT);
finally
Dispose(r);
end;
end;
end;
case FIconSource of
isImageList:
if Assigned(FImages) then
FImages.Draw(FBuffer.Canvas, 14, 16, FImageIndex);
isPNGImage:
if Assigned(FImage) then
FBuffer.Canvas.Draw(14, 16, FImage);
end;
if UxTheme.UseThemes then
begin
theme := OpenThemeData(Handle, 'CONTROLPANEL');
if theme <> 0 then
try
DrawThemeText(theme,
FBuffer.Canvas.Handle,
CPANEL_SECTIONTITLELINK,
CPSTL_NORMAL,
PChar(Caption),
length(Caption),
DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE,
0,
FHeaderRect);
for i := 0 to FLinks.Count - 1 do
DrawThemeText(theme,
FBuffer.Canvas.Handle,
CPANEL_CONTENTLINK,
IfThen(FMouseHoverIndex = i, IfThen(csLButtonDown in ControlState, CPCL_PRESSED, CPCL_HOT), CPCL_NORMAL),
PChar(FLinks[i]),
length(FLinks[i]),
DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE,
0,
FLinkRects[i]
);
finally
CloseThemeData(theme);
end;
end
else
begin
SetNonThemedHeaderFont;
DrawText(FBuffer.Canvas.Handle,
PChar(Caption),
-1,
FHeaderRect,
DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE);
for i := 0 to FLinks.Count - 1 do
begin
SetNonThemedLinkFont(FMouseHoverIndex = i);
DrawText(FBuffer.Canvas.Handle,
PChar(FLinks[i]),
-1,
FLinkRects[i],
DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE);
end;
end;
SwapBuffers;
end;
procedure TTaskButton.SetCaption(const Caption: TCaption);
begin
if not SameStr(FCaption, Caption) then
begin
FCaption := Caption;
UpdateMetrics;
Paint;
end;
end;
procedure TTaskButton.SetHeaderSpacing(HeaderSpacing: integer);
begin
if FHeaderSpacing <> HeaderSpacing then
begin
FHeaderSpacing := HeaderSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TTaskButton.SetIconSource(IconSource: TIconSource);
begin
if FIconSource <> IconSource then
begin
FIconSource := IconSource;
UpdateMetrics;
Paint;
end;
end;
procedure TTaskButton.SetImage(Image: TPngImage);
begin
FImage.Assign(Image);
UpdateMetrics;
Paint;
end;
procedure TTaskButton.SetImageIndex(ImageIndex: TImageIndex);
begin
if FImageIndex <> ImageIndex then
begin
FImageIndex := ImageIndex;
UpdateMetrics;
Paint;
end;
end;
procedure TTaskButton.SetImages(Images: TImageList);
begin
FImages := Images;
UpdateMetrics;
Paint;
end;
procedure TTaskButton.SetImageSpacing(ImageSpacing: integer);
begin
if FImageSpacing <> ImageSpacing then
begin
FImageSpacing := ImageSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TTaskButton.SetLinks(Links: TStrings);
begin
FLinks.Assign(Links);
UpdateMetrics;
Paint;
end;
procedure TTaskButton.SetLinkSpacing(LinkSpacing: integer);
begin
if FLinkSpacing <> LinkSpacing then
begin
FLinkSpacing := LinkSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TTaskButton.SwapBuffers;
begin
BitBlt(Canvas.Handle, 0, 0, Width, Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TTaskButton.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_SIZE:
UpdateMetrics;
CM_MOUSEENTER:
Paint;
CM_MOUSELEAVE:
Paint;
WM_ERASEBKGND:
Message.Result := 1;
end;
end;
procedure TTaskButton.UpdateMetrics;
var
theme: HTHEME;
cr, r: TRect;
i, y: Integer;
begin
FBuffer.SetSize(Width, Height);
SetLength(FLinkRects, FLinks.Count);
if UxTheme.UseThemes then
begin
theme := OpenThemeData(Handle, 'CONTROLPANEL');
if theme <> 0 then
try
with cr do
begin
Top := 10;
Left := ImageWidth + FImageSpacing;
Right := Width - 4;
Bottom := Self.Height;
end;
GetThemeTextExtent(theme,
FBuffer.Canvas.Handle,
CPANEL_SECTIONTITLELINK,
CPSTL_NORMAL,
PChar(Caption),
-1,
DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE,
#cr,
r);
FHeaderHeight := r.Bottom - r.Top;
with FHeaderRect do
begin
Top := 10;
Left := 14 + ImageWidth + FImageSpacing;
Right := Width - 4;
Bottom := Top + FHeaderHeight;
end;
with cr do
begin
Top := 4;
Left := 14 + ImageWidth + FImageSpacing;
Right := Width - 4;
Bottom := Self.Height;
end;
y := FHeaderRect.Bottom + FHeaderSpacing;
for i := 0 to high(FLinkRects) do
begin
GetThemeTextExtent(theme,
FBuffer.Canvas.Handle,
CPANEL_CONTENTLINK,
CPCL_NORMAL,
PChar(FLinks[i]),
-1,
DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE,
#cr,
r);
FLinkHeight := r.Bottom - r.Top;
FLinkRects[i].Left := FHeaderRect.Left;
FLinkRects[i].Top := y;
FLinkRects[i].Right := FLinkRects[i].Left + r.Right - r.Left;
FLinkRects[i].Bottom := FLinkRects[i].Top + FLinkHeight + FLinkSpacing;
inc(y, FLinkHeight + FLinkSpacing);
end;
finally
CloseThemeData(theme);
end;
end
else
begin
SetNonThemedHeaderFont;
FHeaderHeight := FBuffer.Canvas.TextHeight(FCaption);
with FHeaderRect do
begin
Top := 10;
Left := 14 + ImageWidth + FImageSpacing;
Right := Width - 4;
Bottom := Top + FHeaderHeight;
end;
SetNonThemedLinkFont;
y := FHeaderRect.Bottom + FHeaderSpacing;
for i := 0 to high(FLinkRects) do
with FBuffer.Canvas.TextExtent(FLinks[i]) do
begin
FLinkHeight := cy;
FLinkRects[i].Left := FHeaderRect.Left;
FLinkRects[i].Top := y;
FLinkRects[i].Right := FLinkRects[i].Left + cx;
FLinkRects[i].Bottom := FLinkRects[i].Top + FLinkHeight + FLinkSpacing;
inc(y, FLinkHeight + FLinkSpacing);
end;
end;
end;
procedure TTaskButton.SetNonThemedHeaderFont;
begin
with FBuffer.Canvas.Font do
begin
Color := clNavy;
Style := [];
Size := 14;
end;
end;
procedure TTaskButton.SetNonThemedLinkFont(Hovering: boolean = false);
begin
with FBuffer.Canvas.Font do
begin
Color := clNavy;
if Hovering then
Style := [fsUnderline]
else
Style := [];
Size := 10;
end;
end;
initialization
// Override Delphi's ugly hand cursor with the nice Windows hand cursor
Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);
end.
Screenshots:
If I get time over I will add a keyboard interface to it.
I guess this is a customized ListView with activated Tile View.
See "About List-View Controls" on MSDN.
That is part of the Windows shell. It looks like these components wrap the windows shell functionality.

Resources