Title: Bitmap-Button
Question: Rounded buttons with bitmaps for the up/down state
Answer:
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 AColor := GetSysColor (Color and $00FFFFFF);
end else
AColor := Color;
R := GetRValue (AColor);
G := GetGValue (AColor);
B := GetBValue (AColor);
rx := Round ((255-R) * 0.5);
gx := Round ((255-G) * 0.5);
bx := Round ((255-B) * 0.5);
LightC := RGB (R+rx, G+gx, B+bx);
rx := Round (R * 0.3);
gx := Round (G * 0.3);
bx := Round (B * 0.3);
darkC := RGB (R-rx, G-gx, B-bx);
Ha := BeginPaint (Handle, ps);
Canvas.Handle := Ha;
if not Down then begin
with Canvas do begin
if FTPicture.Graphic is TBitmap then begin
Brush.Color := AColor;
FillRect(Rect);
Draw (0, 0, FTPicture.Graphic);
end else begin
Brush.Color := AColor;
FillRect(Rect);
end;
if Border then begin
Brush.Style := bsClear;
Pen.Width := 2;
Pen.Color := LightC;
RoundRect (2, 2, Width, Height, XRadius, YRadius);
Pen.Width := 2;
Pen.Color := DarkC;
RoundRect (0, 0, Width, Height, XRadius, YRadius);
end;
Font := Self.Font;
x := (Width - TextWidth (Caption)) div 2;
y := (Height - TextHeight (Caption)) div 2;
TextOut (x, y, Caption);
end;
end else begin
with Canvas do begin
if FPPicture.Graphic is TBitmap then begin
Brush.Color := AColor;
FillRect(Rect);
Draw (Offset, Offset, FPPicture.Graphic);
end else begin
Brush.Color := AColor;
FillRect(Rect);
end;
if Border then begin
Brush.Style := bsClear;
Pen.Width := 2;
Pen.Color := LightC;
RoundRect (0, 0, Width-2, Height-2, XRadius, YRadius);
Pen.Width := 4;
Pen.Color := DarkC;
RoundRect (0, 0, Width, Height, XRadius, YRadius);
end;
Font := Self.Font;
x := (Width - TextWidth (Caption)) div 2;
y := (Height - TextHeight (Caption)) div 2;
TextOut (x+1, y+1, Caption);
end;
end;
EndPaint (Ha, ps);
end;
procedure TBiButton.PictureChanged(Sender: TObject);
begin
if (FTPicture.Graphic is TBitmap) and (FTPicture.Width = Width) and
(FTPicture.Height = Height) then
ControlStyle := ControlStyle + [csOpaque] else
ControlStyle := ControlStyle - [csOpaque];
if (FPPicture.Graphic is TBitmap) and (FPPicture.Width = Width) and
(FPPicture.Height = Height) then
ControlStyle := ControlStyle + [csOpaque] else
ControlStyle := ControlStyle - [csOpaque];
Invalidate;
end;
procedure TBiButton.WM_LButtonDown (var Msg : TWMLButtonDown);
begin
Pressed := PtInRegion (FRegion, Msg.xPos, Msg.yPos);
if Pressed then begin
Down := Pressed;
SetCapture (Handle);
Invalidate;
end;
inherited;
end;
procedure TBiButton.WM_LButtonUp (var Msg : TWMLButtonUp);
begin
if not Pressed then
exit;
Pressed := False;
Down := Pressed;
ReleaseCapture;
Invalidate;
inherited;
end;
procedure TBiButton.WM_MouseMove (var Msg : TWMMouseMove);
var
D : Boolean;
begin
D := PtInRegion (FRegion, Msg.xPos, Msg.yPos);
if Pressed then begin
if D 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.