Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
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.

https://delphiworld.narod.ru/

DelphiWorld 6.0