Рисование кнопок с кругленными краями

Delphi , Компоненты и Классы , Кнопки

Оформил: 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.

Привет! Я перевёл текст на русский язык:

Интерфейс Единица RVButton определена как класс, наследуясь от TGraphicControl. Она использует несколько других единиц, включая SysUtils, Classes, Controls, Messages, Graphics и Windows.

Константы Определены две константы: iOffset (3) и стандартный цвет кнопки (clBtnFace).

Типы Класс TRVButton объявлен с несколькими приватными полями:

• FCaption: строка, представляющая надпись кнопки
• FButtonColor: TColor, представляющий цвет кнопки
• FLButtonDown: булево значение, указывающее, является ли кнопка нажатой в данный момент
• FBtnPoints: массив из двух объектов TPoint, представляющих координаты верхнего левого и нижнего правого углов круглой области
• FKRgn: HRgn (указатель на регион), используемый для представления круглой формы кнопки

Методы Класс имеет несколько методов:

• SetCaption(Value: string): устанавливает надпись кнопки
• SetButtonColor(Value: TColor): устанавливает цвет кнопки
• FreeRegion(): освобождает память, выделенную для региона (вызывается при уничтожении компонента)
• DrawCircle(): рисует круглую форму кнопки
• MoveButton(): перемещает кнопку в новое положение после нажатия или отпускания
• WMLButtonDown(var Message: TWMLButtonDown): обрабатывает сообщение WM_ LBUTTONDOWN, устанавливая FLButtonDown в True и вызывая MoveButton() если клик мыши находится внутри круглой области
• WMLButtonUp(var Message: TWMLButtonUp): обрабатывает сообщение WM_ LBUTTONUP, устанавливая FLButtonDown в False и вызывая MoveButton() если кнопка была ранее нажата

Конструкторы Конструктор Create(AOwner: TComponent) инициализирует компонент с его владельцем и устанавливает некоторые стандартные свойства.

Деструктор Деструктор Destroy() освобождает память, выделенную для региона (если она не null), перед вызовом наследуемого деструктора.

Метод рисования Метод Paint() переопределяется для рисования кнопки. Он сначала вызывает overridden Paint(), затем освобождает любую существующую область и рисует новую используя DrawCircle(). Наконец, он инвалидирует компонент, чтобы запустить перерисовку.

Альтернативное решение Если вы хотите создать более современный вид кнопки с округленными углами, вы можете использовать встроенный контроллер Delphi TButton с custom стилем. Например:

procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(Button) then
    Button.Perform(CB_Scroll, 0, 0);
end;

procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(Sender) then
     (Sender as TButton).Perform(CB_Scroll, 0, 0);
end;

В этом коде устанавливается стиль кнопки в bsToolButton и используется сообщение CB_Scroll, чтобы нарисовать округленную прямоугольник. Вы можете настроить внешний вид кнопки, установив ее свойства, такие как Font, Color и ImageList.

В статье описывается создание компонента Delphi для рисования кнопок с кругленными краями, который может быть использован в приложениях на основе Windows.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Кнопки ::