Кнопка с закругленными краями

Code:

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.