Rounded buttons with bitmaps for the up/down state

unit Bibutton;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, ExtCtrls;

type
TBiButton = class(TCustomControl)
private
FTPicture : TPicture;
FPPicture : TPicture;
FOnPaint : TNotifyEvent;
FRegion : THandle;
FBRegion : THandle;
FBorder : Boolean;
FOffset : Integer;
FCaption : String;

FXRad,
FYRad : Integer;

Down,
Pressed : Boolean;

procedure SetTPicture (Value : TPicture);
procedure SetPPicture (Value : TPicture);
procedure SetXRadius (Value : Integer);
procedure SetYRadius (Value : Integer);
procedure SetBorder (Value : Boolean);
procedure PictureChanged(Sender : TObject);
procedure WM_LButtonDown (var Msg : TWMLButtonDown); message wm_LButtonDown;
procedure WM_LButtonUp (var Msg : TWMLButtonUp); message wm_LButtonUp;
procedure WM_MouseMove (var Msg : TWMMouseMove); message wm_MouseMove;
procedure WM_Size (var Msg : TWMSize); message wm_Size;
procedure SetRegion;
procedure SetOffest(const Value: Integer);
procedure SetCaption(const Value: String);

public
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
property Canvas;

protected
function GetPalette : HPalette; override;
procedure Paint; override;

published
// The "not-pressed-picture"
property TopPicture : TPicture read FTPicture write SetTPicture;
// The "pressed-picture" - if none, TopPicture will be used
property PressedPicture : TPicture read FPPicture write SetPPicture;
// for round buttons
property XRadius : Integer read FXRad write SetXRadius;
property YRadius : Integer read FYRad write SetYRadius;
// showing a border or not
property Border : Boolean read FBorder write SetBorder;
// offset of the "pressed-picture"
property Offset : Integer read FOffset write SetOffest;
property Caption : String read FCaption write SetCaption;

property Color;
property Font;
property Align;
property Visible;
property ShowHint;
property Enabled;
property ParentColor;
property ParentFont;
property ParentShowHint;
property TabOrder;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('GBit', [TBiButton]);
end;


constructor TBiButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FRegion := 0;
FBRegion := 0;
ControlStyle := [csCaptureMouse, csClickEvents];
FTPicture := TPicture.Create;
FTPicture.OnChange := PictureChanged;
FPPicture := TPicture.Create;
FPPicture.OnChange := PictureChanged;
FBorder := True;
Height := 100;
Width := 100;
XRadius := Width;
YRadius := Height;
Offset := 2;
Pressed := False;
end;


destructor TBiButton.Destroy;
begin
FTPicture.Free;
FPPicture.Free;
DeleteObject (FRegion);
DeleteObject (FBRegion);
inherited Destroy;
end;


function TBiButton.GetPalette: HPalette;
begin
Result := 0;
if FTPicture.Graphic is TBitmap then
Result := TBitmap(FTPicture.Graphic).Palette;
end;


procedure TBiButton.SetTPicture(Value: TPicture);
begin
FTPicture.Assign(Value);
end;


procedure TBiButton.SetPPicture(Value: TPicture);
begin
FPPicture.Assign(Value);
end;


procedure TBiButton.Paint;
var
Rect : TRect;
Ha : HDC;
ps : TPaintStruct;
x, y : Integer;
R, rx,
G, gx,
B, bx : Word;
AColor,
LightC,
DarkC : TColor;
begin
Rect := GetClientRect;
InvalidateRgn (Handle, FRegion, False);
try
SetWindowRgn (Self.Handle, FBRegion, True);
except
end;

if Color < width =" Width)" height =" Height)" width =" Width)" height =" Height)"> Down then begin
Down := D;
Invalidate;
end;
end;
inherited;
end;


procedure TBiButton.SetYRadius (Value : Integer);
begin
if Value > Height then
Value := Height;
if Value <> YRadius then begin
FYRad := Value;
SetRegion;
Invalidate;
end;
end;


procedure TBiButton.SetXRadius (Value : Integer);
begin
if Value > Width then
Value := Width;
if Value <> XRadius then begin
FXRad := Value;
SetRegion;
Invalidate;
end;
end;


procedure TBiButton.SetRegion;
begin
DeleteObject (FRegion);
DeleteObject (FBRegion);
if XRadius > Width then
FXRad := Width;
if YRadius > Height then
FYRad := Height;
FRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
FBRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
end;


procedure TBiButton.WM_Size (var Msg : TWMSize);
begin
SetRegion;
Invalidate;
end;


procedure TBiButton.SetBorder (Value : Boolean);
begin
if Value <> FBorder then begin
FBorder := Value;
Invalidate;
end;
end;

procedure TBiButton.SetOffest(const Value: Integer);
begin
FOffset := Value;
Invalidate;
end;

procedure TBiButton.SetCaption(const Value: String);
begin
FCaption := Value;
Invalidate;
end;

end.