Delphi World - Добавляем кнопку в заголовок окна

Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Добавляем кнопку в заголовок окна
Оформил: DeeCo
Приведённый здесь код создаёт кнопку в заголовке окна, создаёт 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; //Вы можете изменить бэкграунд подсказки...