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

=== Кнопка с закругленными краями ===
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.
Source: http://delphiworld.narod.ru/
ID: 01249