Delphi World - Рисование кнопок с кругленными краями
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Рисование кнопок с кругленными краями

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

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.
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования