Версия для печати


Скин-кнопка от TButton.
http://www.delphikingdom.com/asp/viewitem.asp?catalogID=1095

Сергей Галездинов
дата публикации 09-12-2004 18:17

Скин-кнопка от TButton.

Толчком к этой статье послужил совет Антона Григорьева в обсуждении статьи "Градиентная фантазия". Данная статья, по сути, является ее продолжением. В ней я покажу пример использования градиентной заливки для украшения интерфейса.

Итак, в этой статье поговорим о том, как создать кнопку с возможностью натягивания скинов. Причем, эта кнопка должна обладать всеми свойствами кнопки (я имею в виду TButton). Долгое время я мучился над этим вопросом. Первым решением было создать компонент от TGraphicControl. Но есть три недостатка, которые заставили отказаться от этой идеи:

Согласитесь, это не есть гуд...

Второй шаг - сделать на основе кода BitBtn. Однако, и в этом случае столкнулся с рядом проблем. В итоге, я начал просматривать всю иерархию классов в поиске решения. Все-таки VCL - кладезь знаний, где можно найти очень много интересного. После некоторого времени я нашел все-таки выход. Выход, который дал возможности и скинов, и всех свойств кнопки, включая фокус и ModalResult. Я нашел класс TCustomControl. По сути, WinControl с возможностью собственной отрисовки, т.е. то, что нам нужно. Можно было наследовать скин-кнопку уже от него, но дублировать код TButton не хотелось, поэтому я решил применить метод переопределения отрисовки, используемый в классе TCustomControl.

Если посмотреть структуру класса: 

TCustomControl = class(TWinControl)
  private
    FCanvas: TCanvas;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    property Canvas: TCanvas read FCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

можно увидеть, что переопределяется метод PaintWindow (хитрО, очень хитрО), в котором вызывается собственный метод Paint, который можно будет переопределить. Как это сделано? Не забудем, что это винконтрол и простым отловом события WM_PAINT не обойдешься. Нужно сделать вот так:

procedure TCustomControl.WMPaint(var Message: TWMPaint);
begin
  Include(FControlState, csCustomPaint);
  inherited;
  Exclude(FControlState, csCustomPaint);
end;

Т.е временно в обработчике события в список состояний контрола добавляется csCustomPaint вызывается метод PaintWindow и csCustomPaint исключается из списка. Посмотрим, что там в справке написано?

csCustomPaint	The control is processing custom paint messages.
То бишь контрол обрабатывает сообщения отрисовки.

Все, что нам потребуется - это сделать также в нашем компоненте, унаследованном от TButton. Есть еще небольшой нюанс. Придется переопределить пару-тройку методов, чтобы не было видно старой отрисовки кнопки. Ведь мы обрабатываем только WM_Paint, а кнопка отрисовывается еще в нескольких случаях:

  1. При нажатии на нее мышью.
  2. При переходе фокуса.
  3. При нажатии клавиш-акселераторов(пробел, Enter)
  4. При переходах в разрешенное и неразрешенное состояние.
Чем и займемся. Итак, вот листинг компонента с подробными комментариями. 

unit SegaButton;

interface

uses
  Windows, Messages, SysUtils,
  Classes, Controls, StdCtrls,
  Graphics, SegaGradients;

type
  TAboutProperty = type string; //свойство, для которого я сделал редактор -
                                //простое about окно.
  TSegaButton = class(TButton)
  private
    FCanvas: TCanvas;         //канвас, на котором, собственно и будем рисовать
    FSkinPushed: TBitmap;     // \
    FSkinDisabled: TBitmap;   //   \  битмапы, в которых будут храниться
    FSkinNormal: TBitmap;     //   / скины.
    FSkinOver: TBitmap;       //  /
    FOnMouseLeave: TNotifyEvent;  // добавим два события -
    FOnMouseEnter: TNotifyEvent;   // вход и уход мыши с кнопки
    IsOver,Pushed: Boolean; //флаги состояния кнопки
    FFocuse: TColor;    //цвет прямоугольника фокуса - мало ли какой скин будет
    FAbout: TAboutProperty;
    FSize: Boolean;     //флаг автоматического выравнивания кнопки под caption
    FMinW: Integer;     //минимальная ширина
    FMinH: Integer;     // и высота кнопки
    //обработчики событий, позволяющих нажать на кнопку програмно и
    //узнать о ее состоянии
    procedure BMSetState(var Message: TMessage);message BM_SETSTATE;
    procedure BMGetState(var Message: TMessage);message BM_GETSTATE;
    //отлов нажатий клавиш-акселераторов
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    //отлов изменений текста и шрифта
    procedure CMTextChanged(var Message: TMessage);message CM_TEXTCHANGED;
    procedure CMFontChanged(var Message: TMessage);message CM_FONTCHANGED;
    // отлов событий входа и ухода мыши с кнопки
    procedure CMMouseOver(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    //метод отлова сообщения об отрисовке
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    // установка значений свойств
    procedure SetSkinDisabled(const Value: TBitmap);
    procedure SetSkinNormal(const Value: TBitmap);
    procedure SetSkinOver(const Value: TBitmap);
    procedure SetSkinPushed(const Value: TBitmap);
    procedure SetFocuseColor(const Value: TColor);
    procedure SetSize(const Value: Boolean);
    procedure SetMinH(const Value: Integer);
    procedure SetMinW(const Value: Integer);
  protected
    function GetPushed: Boolean;
    //эти два метода я украл из TLabel и немного переработал -
    //грубо, но работает:)
    procedure DoDrawText(var Rect: TRect; Flags: Integer);
    procedure AdjustBounds;
    //это уж наверное догадались для чего:)
    procedure SetEnabled(Value: Boolean); override;
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    property Canvas: TCanvas read FCanvas;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property IsPushed: Boolean read GetPushed;
  published
    property About: TAboutProperty read FAbout write FAbout;
    property AutoSize: Boolean read FSize write SetSize default True;
    property SkinOver: TBitmap read FSkinOver write SetSkinOver;
    property SkinPushed: TBitmap read FSkinPushed write SetSkinPushed;
    property SkinNormal: TBitmap read FSkinNormal write SetSkinNormal;
    property SkinDisabled: TBitmap read FSkinDisabled write SetSkinDisabled;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property FocusRectColor: TColor read FFocuse write SetFocuseColor default clWhite;
    property MinHeight: Integer read FMinH write SetMinH default 25;
    property MinWidth: Integer read FMinW write SetMinW default 75;
  end;

implementation

{ TSegaButton }

//подстраиваем ширину и высоту кнопки так, чтобы она полностью вмещала caption
//(c учетом ограничений)
procedure TSegaButton.AdjustBounds;
var
  DC: HDC;
  theRect: TRect;
  AAlignment: TAlignment;
  VarHeight,VarWidth: Integer;

begin
if FSize then begin
  theRect := Rect(ClientRect.Left+4, ClientRect.Top,
                  ClientRect.Right-4,ClientRect.Bottom);
  DC := GetDC(0);
  Canvas.Handle := DC;
  DoDrawText(theRect, (DT_EXPANDTABS or DT_CALCRECT));
  Canvas.Handle := 0;
  ReleaseDC(0, DC);
  AAlignment := taCenter;

  if UseRightToLeftAlignment then
    ChangeBiDiModeAlignment(AAlignment);
    VarHeight:=(TheRect.Top - TheRect.Bottom);
    VarWidth := (theRect.Right+2-theRect.Left);

if VarHeight < FMinH then VarHeight := FMinH;
if VarWidth < FMinW then VarWidth := FMinW;

  Width := VarWidth;
  Height := VarHeight;
              end;
end;

//так, на всякий случай
procedure TSegaButton.BMGetState(var Message: TMessage);
begin
if Pushed then Message.Result := 1
                else Message.Result := 0;
end;

//устанавливаем Pushed и отрисовываем
procedure TSegaButton.BMSetState(var Message: TMessage);
begin
case Message.WParam of
0: Pushed := False;
1: Pushed := True;
end;
Invalidate;
end;

//клавиши - акселераторы- вызываем родительский метод и перерисовываем
procedure TSegaButton.CMDialogChar(var Message: TCMDialogChar);
begin
  inherited;
  Invalidate;
end;

procedure TSegaButton.CMDialogKey(var Message: TCMDialogKey);
begin
  inherited;
  Invalidate;
end;

//в случае изменения шрифта нужно перерисовать кнопку - с учетом размера шрифта
procedure TSegaButton.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

//наши собственные события. Если есть обработчик, вызываем  его, не
//забываем отрисовать заново
procedure TSegaButton.CMMouseLeave(var Message: TMessage);
begin
  IsOver:= False;
  Invalidate;
  if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
end;

procedure TSegaButton.CMMouseOver(var Message: TMessage);
begin
  IsOver:= True;
  Invalidate;
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;

//Когда изменяется текст кнопки, нужно ее перерисовать.
//Если AutoSize установлен в True
//то нужно будет изменить размеры кнопки
procedure TSegaButton.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

//инициализация всех переменных
constructor TSegaButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;

  ControlStyle := ControlStyle + [csOpaque]; //это для прозрачности
  FSkinOver     := TBitmap.Create;
  FSkinPushed   := TBitmap.Create;
  FSkinNormal   := TBitmap.Create;
  FSkinDisabled := TBitmap.Create;

  FSkinOver.Transparent := True;
  FSkinPushed.Transparent := True;
  FSkinNormal.Transparent := True;
  FSkinDisabled.Transparent := True;

  IsOver := False;
  Pushed := False;
  FFocuse := clWhite;
  FSize := True;
  FMinW := 75;
  FMinH := 25;
end;

destructor TSegaButton.Destroy;
begin
  FSkinOver.Free;
  FSkinPushed.Free;
  FSkinNormal.Free;
  FSkinDisabled.Free;
  FCanvas.Free;
  inherited Destroy;
end;

//процедурка, нужная для того, чтобы узнать размеры, необходимые
//для вмещения всего caption'а
//ничего не изменял. Лень:))
procedure TSegaButton.DoDrawText(var Rect: TRect; Flags: Integer);
var
  Text: string;
begin
  Text := '  ' + Caption + '  ';
  if (Flags and DT_CALCRECT <> 0) and (Text = '') then Text := Text + '     ';
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end;

//узнаем состояние кнопки - нажата - не нажата
function TSegaButton.GetPushed: Boolean;
begin
  Result := Pushed;
end;


//реакция на нажатие пробела - не знаю почему, но на него надо отдельно:(
procedure TSegaButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Key = VK_SPACE then Pushed := True;
  Invalidate;
end;

procedure TSegaButton.KeyUp(var Key: Word; Shift: TShiftState);
begin
  if Key = VK_SPACE then
    begin
      Invalidate;
      Pushed := False;
      inherited Click;
    end;
  inherited;

end;

//переопределим нажатие кнопки мыши - изменяем состояние и перерисовываем
procedure TSegaButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  Pushed := True;
  Invalidate;
end;

procedure TSegaButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  Pushed := False;
  Invalidate;
  inherited Click;
  inherited;
end;

// самая интересная часть - отрисовка кнопки - вот где можно
// разгуляться от души:))
// по дефолту я рисую кнопку а-ля Punto Switcher - посмотрите меню настроек
procedure TSegaButton.Paint;
var X, Y: Integer;
      BtnRect: TRect;
      ColArr: TColorArray;
begin
AdjustBounds;
SetLength(ColArr,HorizontalArrayWidth(ClientRect) + 1);// массив под цвета -
//кто читал мою предыдущую статью, знает, для чего

Canvas.Brush.Style := bsClear; //текст будем выводить с прозрачной
                               //кистью - чтобы не портить скин
Canvas.Brush.Color := Parent.Brush.Color; //цвет - цвет родителя
Canvas.FillRect(ClientRect);              //заливаем всю область

BtnRect := ClientRect;
Canvas.Font := Font;

if not Enabled then
   begin
//если кнопка запрещена, то
     if not FSkinDisabled.Empty
        then //если скин есть, то рисуем его
          Canvas.StretchDraw(BtnRect,FSkinDisabled)
        else
          begin
              //иначе рисуем сами:
             SimpleFillArray(clWhite,
                             clSilver,
                             ColArr,
                             HorizontalArrayWidth(ClientRect));
             HorizontalGradient(Canvas,
                                ClientRect,
                                ColArr);
             Canvas.Pen.Color := clWhite;
             Canvas.MoveTo(0, 0);
             Canvas.LineTo(Width, 0);
             Canvas.LineTo(Width, Height);
             Canvas.LineTo(0, Height);
             Canvas.LineTo(0, 0);

             Canvas.Pen.Color := clGray;
             Canvas.MoveTo(Width - 2, 1);
             Canvas.LineTo(Width - 2, Height - 2);
             Canvas.LineTo(1, Height - 2);

             Canvas.Pen.Color := clBlack;
             Canvas.MoveTo(Width - 2, 1);
             Canvas.LineTo(1, 1);
             Canvas.LineTo(1, Height - 2);
           end;
   end//if not enabled
else
begin
//Если нажата:
if Pushed
then begin
       if not FSkinPushed.Empty
         then
           Canvas.StretchDraw(BtnRect,FSkinPushed)
         else
           begin
             SimpleFillArray(clWhite,
                             clSilver,
                             ColArr,
                             HorizontalArrayWidth(ClientRect));
             HorizontalGradient(Canvas,
                                ClientRect,
                                ColArr);
             Canvas.Pen.Color := clBlack;
             Canvas.MoveTo(Width - 1, 0);
             Canvas.LineTo(0,0);
             Canvas.LineTo(0, Height - 1);

             Canvas.Pen.Color := clWhite;
             Canvas.MoveTo(0,Height - 1);
             Canvas.LineTo(Width - 1,Height - 1);
             Canvas.LineTo(Width - 1, - 1);
           end;
     end//if Pushed
else begin
//иначе если над кнопкой
  if IsOver
   then begin
          if not FSkinOver.Empty
             then
               Canvas.StretchDraw(BtnRect,FSkinOver)
             else
               begin
                 ComplexFillArray([clWhite,clSilver,$008F8F8F],
                                   ColArr,
                                   HorizontalArrayWidth(ClientRect));
                 HorizontalGradient(Canvas,
                                    ClientRect,
                                    ColArr);
                 Canvas.Pen.Color := clWhite;
                 Canvas.MoveTo(Width - 1, 0);
                 Canvas.LineTo(0,0);
                 Canvas.LineTo(0, Height - 1);

                 Canvas.Pen.Color := clBlack;
                 Canvas.MoveTo(0, Height - 1);
                 Canvas.LineTo(Width - 1, Height - 1);
                 Canvas.LineTo(Width - 1, - 1);
               end;
        end//if IsOver
   else begin
         if Pushed then Exit;
          if not FSkinNormal.Empty
            then
              Canvas.StretchDraw(BtnRect,FSkinNormal)
            else
              begin
                SimpleFillArray(clWhite,
                                clSilver,
                                ColArr,
                                HorizontalArrayWidth(ClientRect));
                 HorizontalGradient(Canvas,
                                    ClientRect,
                                    ColArr);
                 Canvas.Pen.Color := clWhite;
                 Canvas.MoveTo(Width - 1, 0);
                 Canvas.LineTo(0,0);
                 Canvas.LineTo(0, Height - 1);

                 Canvas.Pen.Color := clBlack;
                 Canvas.MoveTo(0,Height - 1);
                 Canvas.LineTo(Width - 1,Height - 1);
                 Canvas.LineTo(Width - 1, - 1);
              end;
        end;//else not IsOver
     end;//else not Pushed
end;//else enabled

//выводим текст:
Y := Height div 2 - Canvas.TextHeight(Caption) div 2;
X := Width div 2 - Canvas.TextWidth(Caption) div 2;
if X < 2 then X := 2;
if Pushed and Enabled then
begin
//если разрешена и нажата, то для более выраженного эффекта
// нажатой кнопки выводим текст чуть ниже и правее
  inc(X);
  inc(Y);
end;
Canvas.Brush.Color := clBtnFace;
InflateRect(BtnRect,- 5, - 5);
Canvas.Brush.Style := bsClear;
Canvas.TextRect(BtnRect, X, Y, Caption);

if Focused
   then begin
//рисуем фокус
          Canvas.Brush.Color := FFocuse;
          Canvas.DrawFocusRect(BtnRect);
        end;

Finalize(ColArr); //не забудем освободить массив
end;

//Это слизано с TCustomControl
procedure TSegaButton.PaintWindow(DC: HDC);
begin
  FCanvas.Lock;
  try
    FCanvas.Handle := DC;
    try
      TControlCanvas(FCanvas).UpdateTextFlags;
      Paint;
    finally
      FCanvas.Handle := 0;
    end;
  finally
    FCanvas.Unlock;
  end;
end;

//А это уже не интересно - установка значений свойтсв
procedure TSegaButton.SetEnabled(Value: Boolean);
begin
  inherited;
  Invalidate;
end;

procedure TSegaButton.SetFocuseColor(const Value: TColor);
begin
  FFocuse := Value;
  Invalidate;
end;

procedure TSegaButton.SetMinH(const Value: Integer);
begin
  FMinH := Value;
  Invalidate;
end;

procedure TSegaButton.SetMinW(const Value: Integer);
begin
  FMinW := Value;
  Invalidate;
end;

procedure TSegaButton.SetSize(const Value: Boolean);
begin
  FSize := Value;
  if Value then AdjustBounds;
end;

procedure TSegaButton.SetSkinDisabled(const Value: TBitmap);
begin
  FSkinDisabled.Assign(Value);
  Invalidate;
end;

procedure TSegaButton.SetSkinNormal(const Value: TBitmap);
begin
  FSkinNormal.Assign(Value);
  Invalidate;
end;

procedure TSegaButton.SetSkinOver(const Value: TBitmap);
begin
  FSkinOver.Assign(Value);
  Invalidate;
end;

procedure TSegaButton.SetSkinPushed(const Value: TBitmap);
begin
  FSkinPushed.Assign(Value);
  Invalidate;
end;

procedure TSegaButton.WMPaint(var Message: TWMPaint);
begin
  ControlState := ControlState + [csCustomPaint];
  inherited;
  ControlState := ControlState - [csCustomPaint];
end;

end.

Вот и все. С рантайм-частью все сделано. Теперь модуль регистрации компонента и редактора свойства About: 

unit SegaButtonReg;

interface

uses SegaButton, Classes, Dialogs,
        Forms, SysUtils, Graphics,
        Controls, DesignIntf, DesignEditors,
        AboutForm, StdCtrls, ExtCtrls, ComCtrls;

type

TAboutPropertyEditor=class(TStringProperty)
    public
     function GetAttributes: TPropertyAttributes; override;
     function GetValue : String; override;
     procedure Edit; override;
    end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Sega Graphics', [TSegaButton]);
  RegisterPropertyEditor(TypeInfo(TAboutProperty),
                         TSegaButton,
                         'About',
                         TAboutPropertyEditor);
end;

{ TAboutPropertyEditor }

procedure TAboutPropertyEditor.Edit;
var dlg: TAboutWindow;
begin
dlg := TAboutWindow.Create(Application);
try
dlg.ShowModal;
finally
dlg.Free;
end;
end;

function TAboutPropertyEditor.GetAttributes: TPropertyAttributes;
begin
 Result := [paDialog,paReadOnly];
end;

function TAboutPropertyEditor.GetValue: String;
begin
 Result := 'version 1.0';
end;

end.

Здесь в принципе и объяснять нечего... Но если вы хотите разобраться, то почитайте статью Ирины Аринович - "Сапоги для сапожника". Очень интересно и понятно почти любому. Мне чтобы понять, как делать хотя бы такой редактор пришлось лопатить ToolsAPI и DesignIntf. Справка действительно скудная... Если бы мне тогда попалась эта статья, я бы написал и лучше, и быстрее.

В заключение хочется сказать о недостатках этого компонента. Один недостаток - я сделал только битмапы на скин, но вы можете и другие типы изображений, заменив TBitmap на TGraphic. Другой недостаток - если удерживать кнопку мыши на кнопке и двигать ей, то будет наблюдаться мерцание. Возможно, вы и сами сможете это исправить, я пока не могу - сложна жизнь студента:)

С уважением, Sega-Zero.


К материалу прилагаются файлы: