unit Unit26;

 

interface

 

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

  Dialogs, ExtCtrls, StdCtrls;

 

type

  TForm26 = class(TForm)

    Panel1: TPanel;

    Button1: TButton;

    procedure FormCreate(Sender: TObject);

    procedure FormResize(Sender: TObject);

  private

    Btn : TRect;

    FButtonDown, FButtonHot: Boolean;

    procedure DrawButton;

    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;

    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;

    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;

    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

    procedure WMNCLButtonUp(var Msg : TWMNCLButtonUp); message WM_NCLBUTTONUP;

    procedure WMNCmouseMove(var Msg : TWMNCMouseMove); message WM_NCMOUSEMOVE;

  end;

 

var

  Form26: TForm26;

 

implementation

 

{$R *.dfm}

 

uses

  Themes, Buttons, Types;

 

const

  htCaptionBtn = htSizeLast + 1;

 

procedure TForm26.DrawButton;

var

  FrameWidth,

  FrameHeight,

  BtnWidth,

  BtnHeight  : Integer;

  TmpCanvas: TCanvas;

  BtnCaption: String;

  Details: TThemedElementDetails;

begin

  FrameWidth := GetSystemMetrics(SM_CXBORDER);

  FrameHeight := GetSystemMetrics(SM_CYBORDER);

  // Смотрим - какого размера должна быть кнопка

  BtnWidth  := GetSystemMetrics(SM_CXHSCROLL);

  BtnHeight  := GetSystemMetrics(SM_CYHSCROLL);

  // Определяем позицию новой кнопки

  Btn := Bounds(Width - BtnWidth - FrameWidth - 4,

    Height - BtnHeight - FrameHeight - 4, BtnWidth, BtnHeight);

  TmpCanvas := TCanvas.Create;

  try

    // Получаем ссылку на канвас всего окна

    // (Form.Canvas - указывает на канвас только клиентской области)

    TmpCanvas.Handle := GetWindowDC(Handle);

    try

      TmpCanvas.Font.Color := clBlue;

      TmpCanvas.Font.Style := [fsBold];

      TmpCanvas.Pen.Color := clYellow;

      TmpCanvas.Brush.Color := clBtnFace;

      // Отрисовка кнопки в случае если используются темы Windows

      if ThemeServices.ThemesEnabled and (not(csDesigning in ComponentState)) then

      begin

        if FButtonDown then

          Details := ThemeServices.GetElementDetails(tbPushButtonPressed)

        else

          if FButtonHot then

            Details := ThemeServices.GetElementDetails(tbPushButtonHot)

          else

            Details := ThemeServices.GetElementDetails(tbPushButtonNormal);

        ThemeServices.DrawElement(TmpCanvas.Handle, Details, Btn);

      end

      else

      begin // А так рисуем если темы отсутствуют

        // Рисуем кнопку

        DrawButtonFace(TmpCanvas, Btn, 1, bsAutoDetect, False, FButtonDown, False);

      end;

      // Определяем координаты текста на ней

      BtnCaption := 'Z';

      Btn.Left := Btn.Left +

        ((Btn.Right - Btn.Left - TmpCanvas.TextWidth(BtnCaption)) div 2);

      Btn.Top := Btn.Top +

        ((Btn.Bottom - Btn.Top - TmpCanvas.TextHeight(BtnCaption)) div 2);

      // рисуем текст

      TmpCanvas.Brush.Style := bsClear;

      with Btn do

        TmpCanvas.TextRect(Btn, Left, Top, BtnCaption);

    finally

      ReleaseDC(Handle, TmpCanvas.Handle);

    end;

  finally

    TmpCanvas.Free;

  end;

end;

 

procedure TForm26.FormCreate(Sender: TObject);

begin

  FButtonDown := False;

end;

 

procedure TForm26.FormResize(Sender: TObject);

begin

  Perform(WM_NCACTIVATE, Word(Active), 0);

end;

 

procedure TForm26.WMNCActivate(var Msg: TWMNCActivate);

begin

  inherited;

  DrawButton;

end;

 

procedure TForm26.WMNCHitTest(var Msg: TWMNCHitTest);

begin

  inherited;

  with Msg do

  begin

    FButtonHot := PtInRect(Btn, Point(XPos - Left, YPos - Top));

    if FButtonHot then Result := htCaptionBtn;

  end;

end;

 

procedure TForm26.WMNCLButtonDown(var Msg: TWMNCLButtonDown);

begin

  inherited;

  if (Msg.HitTest = htCaptionBtn) then

  begin

    FButtonDown := True;

    DrawButton;

    // Тут добавить обработку нажатия кнопки

  end;

end;

 

procedure TForm26.WMNCLButtonUp(var Msg: TWMNCLButtonUp);

begin

  inherited;

  FButtonDown := False;

  DrawButton;

end;

 

procedure TForm26.WMNCmouseMove(var Msg: TWMNCMouseMove);

begin

  inherited;

  with Msg do

  begin

    FButtonHot := PtInRect(Btn, Point(XCursor - Left, YCursor - Top));

    DrawButton;

  end;

end;

 

procedure TForm26.WMNCPaint(var Msg: TWMNCPaint);

begin

  inherited;

  DrawButton;

end;

 

procedure TForm26.WMSetText(var Msg: TWMSetText);

begin

  inherited;

  DrawButton;

end;

 

end.