Добавляем кнопку в заголовок окна.

Автор: Tercio Ferdinando Gaudencio Filho

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.

Совместимость: Delphi 3.x (или выше)

...

  private
    { Private declarations }
    procedure WMNCPAINT          (var msg: Tmessage); message WM_NCPAINT;
    procedure WMNCACTIVATE       (var msg: Tmessage); message WM_NCACTIVATE;
    procedure WMNCMOUSEDOWN      (var msg: Tmessage); message WM_NCLBUTTONDOWN;
    procedure WMNCMOUSEMOVE      (var Msg: TMessage); message WM_NCMOUSEMOVE;
    procedure WMMOUSEMOVE        (var Msg: TMessage); message WM_MOUSEMOVE;
    procedure WMLBUTTONUP        (var msg: Tmessage); message WM_LBUTTONUP;
    procedure WNCLBUTTONDBLCLICK (var msg: Tmessage); message WM_NCLBUTTONDBLCLK;
    procedure WMNCRBUTTONDOWN    (var msg: Tmessage); message WM_NCRBUTTONDOWN;
    procedure WMNCHITTEST        (var msg: Tmessage); message WM_NCHITTEST;
    procedure WMSYSCOMMAND       (var msg: Tmessage); message WM_SYSCOMMAND;

...

var
...
  Pressed         : Boolean;
  FocusLost       : Boolean;
  Rec             : TRect;
  NovoMenuHandle  : THandle;
  PT1             : TPoint;
  FHintshow       : Boolean;
  FHint           : THintWindow;
  FHintText       : String;
  FHintWidth      : Integer;

...

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage);
begin
  if Msg.WParam=LongInt(NovoMenuHandle) then
    //*********************************************
    //Кнопка была нажата! Добавьте сюда Вашу функцию
    //*********************************************
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage);
var
  Tmp : Boolean;
begin
  if Pressed then
  begin
    Tmp:=FocusLost;
    PT1.X := Msg.LParamLo - FrmMainForm.Left;
    PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
    if PTInRect(Rec, PT1) then
      FocusLost := False
    else
      FocusLost := True;
    if FocusLost <> Tmp then
      InvalidateRect(FrmMainForm.Handle, @Rec, True);
  end;
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage);
var
  Tmp : Boolean;
begin
  ReleaseCapture;
  Tmp     := Pressed;
  Pressed := False;
  if Tmp and PTInRect(Rec, PT1) then
  begin
    InvalidateRect(FrmMainForm.Handle, @Rec, True);
    FHintShow := False;
    FHint.ReleaseHandle;
    //*********************************************
    //Кнопка была нажата! Добавьте сюда Вашу функцию
    //*********************************************
  end
  else
    inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  if not PTInRect(Rec, PT1) then
    inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  if not PTInRect(Rec, PT1) then
    inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  FHintShow := False;
  if PTInRect(Rec, PT1) then
  begin
   Pressed   := True;
   FocusLost := False;
   InvalidateRect(FrmMainForm.Handle, @Rec, True);
   SetCapture(TWinControl(FrmMainForm).Handle);
  end
  else
  begin
   FrmMainForm.Paint;
   inherited;
  end;
end;

//------------------------------------------------------------------------------

//That function Create a Hint
procedure TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  if PTInRect(Rec, PT1) then
  begin
    FHintWidth  := FHint.Canvas.TextWidth(FHintText);
    if (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then
      FHint.ActivateHint(
        Rect(
          Mouse.CursorPos.X,
          Mouse.CursorPos.Y + 20,
          Mouse.CursorPos.X + FHintWidth + 10,
          Mouse.CursorPos.Y + 35
          ),
        FHintText
      );
      FHintShow := True;
  end
  else
  begin
    FHintShow := False;
    FHint.ReleaseHandle;
  end;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage);
begin
  FHintShow := False;
  FHint.ReleaseHandle;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.FormPaint(Sender:TObject);
var
  Border3D_Y, Border_Thickness, Btn_Width,
  Button_Width, Button_Height  : Integer;
  MyCanvas                      : TCanvas;
begin
  MyCanvas        := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(FrmMainForm.Handle);
  Border3D_Y      := GetSystemMetrics(SM_CYEDGE);
  Border_Thickness:= GetSystemMetrics(SM_CYSIZEFRAME);
  Button_Width    := GetSystemMetrics(SM_CXSIZE);
  Button_Height   := GetSystemMetrics(SM_CYSIZE);

  //Создаём квадратную кнопку, но если Вы захотите создать кнопку другого размера, то
  //измените эту переменную на Вашу ширину.
  Btn_Width  := Border3D_Y  + Border_Thickness + Button_Height - (2 * Border3D_Y) - 1;

  Rec.Left   := FrmMainForm.Width - (3 * Button_Width + Btn_Width);
  Rec.Right  := FrmMainForm.Width - (3 * Button_Width + 03);
  Rec.Top    := Border3D_Y  + Border_Thickness - 1;
  Rec.Bottom := Rec.Top     + Button_Height - (2 * Border3D_Y);
  FillRect(MyCanvas.Handle,Rec,HBRUSH(COLOR_BTNFACE+1));
  If not Pressed or Focuslost Then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED, BF_SOFT or BF_RECT)
  Else If Pressed and Not Focuslost Then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN, BF_SOFT or BF_RECT);

  //It draw a the application icon to the button. Easy to change.
  DrawIconEX(MyCanvas.Handle, Rec.Left+4, Rec.Top+3, Application.Icon, 8, 8, 0, 0, DI_NORMAL);

  MyCanvas.Free;
end;

...

procedure TFrmMainForm.FormCreate(Sender: TObject);

...

  InsertMenu(GetSystemMenu(Handle,False), 4, MF_BYPOSITION+MF_STRING, NovoMenuHandle,pchar('TEXT OF THE MENU'));
  Rec             := Rect(0,0,0,0);
  FHintText       := 'Put the text of your Hint HERE';
  FHint           := THintWindow.Create(Self);
  FHint.Color     := clInfoBk;  //Вы можете изменить бэкграунд подсказки

...