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

Автор: 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;  //Вы можете изменить бэкграунд подсказки

... 

Ведение беременности практика в клинике плюс 9

---