...draw buttons with rounded corners?

Author: Alain Gosselin  

unit RVButton;

interface

uses

 SysUtils, Classes, Controls, Messages, Graphics, Windows;

const

 iOffset = 3;

type

 TRVButton = class(TGraphicControl)

 private

   FCaption : string;

   FButtonColor: TColor;

   FLButtonDown: boolean;

   FBtnPoints : array[1..2] of TPoint;

   FKRgn : HRgn;

   procedure SetCaption(Value: string);

   procedure SetButtonColor(Value: TColor);

   procedure FreeRegion;

 protected

   procedure Paint; override;

   procedure DrawCircle;

   procedure MoveButton;

   procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;

   procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;

 public

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

 published

   property ButtonColor: TColor read FButtonColor write SetButtonColor;

   property Caption: string read FCaption write SetCaption;

   property Enabled;

   property Font;

   property ParentFont;

   property ParentShowHint;

   property ShowHint;

   property Visible;

   property OnClick;

 end;

procedure Register;

implementation

procedure Register;

begin

 RegisterComponents('Samples', [TRVButton]);

end;

{ TRVButton }

constructor TRVButton.Create(AOwner: TComponent);

begin

 inherited Create(AOwner);

 ControlStyle := [csClickEvents,csCaptureMouse];

 Width := 50;

 Height := 50;

 FButtonColor := clBtnFace;

 FKRgn := 0;

 FLButtonDown := False;

end;

destructor TRVButton.Destroy;

begin

 if FKRgn <> 0 then FreeRegion;

 inherited Destroy;

end;

procedure TRVButton.DrawCircle;

begin

 FBtnPoints[1] := Point(iOffset,iOffset);

 FBtnPoints[2] := Point(Width - iOffset,Height - iOffset);

 FKRgn := CreateEllipticRgn(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y);

 Canvas.Brush.Color := FButtonColor;

 FillRgn(Canvas.Handle,FKRgn,Canvas.Brush.Handle);

 MoveButton;

end;

procedure TRVButton.FreeRegion;

begin

 if FKRgn <> 0 then DeleteObject(FKRgn);

 FKRgn := 0;

end;

procedure TRVButton.MoveButton;

var

 Color1: TColor;

 Color2: TColor;

begin

 with Canvas do

   begin

   if not FLButtonDown then

     begin

     Color1 := clBtnHighlight;

     Color2 := clBtnShadow;

     end

   else

     begin

     Color1 := clBtnShadow;

     Color2 := clBtnHighLight;

     end;

     Pen.Width := 1;

     if FLButtonDown then Pen.Color := clBlack

     else                 Pen.Color := Color2;

     Ellipse(FBtnPoints[1].x - 2,FBtnPoints[1].y - 2,FBtnPoints[2].x + 2,FBtnPoints[2].y + 2);

     if not FLButtonDown then Pen.Width := 2

     else                     Pen.Width := 1;

     Pen.Color := Color1;

     Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,

         FBtnPoints[2].x,FBtnPoints[1].y,FBtnPoints[1].x,FBtnPoints[2].y);

     Pen.Color := Color2;

     Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,

         FBtnPoints[1].x,FBtnPoints[2].y,FBtnPoints[2].x,FBtnPoints[1].y);

     end;

 SetCaption('');

end;

procedure TRVButton.Paint;

begin

 inherited Paint;

 FreeRegion;

 DrawCircle;

end;

procedure TRVButton.SetButtonColor(Value: TColor);

begin

 if Value <> FButtonColor then

   begin

   FButtonColor := Value;

   Invalidate;

   end;

end;

procedure TRVButton.SetCaption(Value: string);

var

 X: Integer;

 Y: Integer;

begin

 if ((Value <> FCaption) and (Value <> '')) then

 begin

   FCaption := Value;

 end;

 with Canvas.Font do

 begin

   Name  := Font.Name;

   Size  := Font.Size;

   Style := Font.Style;

   if Self.Enabled then Color := Font.Color

   else

     Color := clDkGray;

 end;

 X := (Width div 2) - (Canvas.TextWidth(FCaption) div 2);

 Y := (Height div 2) - (Canvas.TextHeight(FCaption) div 2);

 Canvas.TextOut(X, Y, FCaption);

 //  Invalidate;

end;

procedure TRVButton.WMLButtonDown(var Message: TWMLButtonDown);

begin

 if not PtInRegion(FKRgn,Message.xPos,Message.yPos) then exit;

 FLButtonDown := True;

 MoveButton;

 inherited;

end;

procedure TRVButton.WMLButtonUp(var Message: TWMLButtonUp);

begin

 if not FLButtonDown then exit;

 FLButtonDown := False;

 MoveButton;

 inherited;

end;

end.