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

---

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

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

Итак, в этой статье поговорим о том, как создать кнопку с возможностью натягивания скинов. Причем, эта кнопка должна обладать всеми свойствами кнопки (я имею в виду 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. Другой недостаток - если удерживать кнопку мыши на кнопке и двигать ей, то будет наблюдаться мерцание. Возможно, вы и сами сможете это исправить, я пока не могу - сложна жизнь студента:)

• Используемые компоненты (129 K) обновление от 12/9/2004 6:17:00 PM