Добавляем дополнительную кнопку в заголовок формы

=== Добавляем дополнительную кнопку в заголовок формы ===
Чтобы добавить дополнительную кнопку, нам прийдётся создать обработчики для следующих событий:
 WM_NCPAINT; вызывается, когда перерисовывается не клиентская область формы 
 WM_NCACTIVATE; вызывается, когда заголовок формы становится активныи 
 WM_NCLBUTTONDOWN; вызывается, когда кнопка мыши нажимается на не клиентской области 
 WM_NCMOUSEMOVE; вызывается, когда курсор мыши передвигается по не клиентской области
 WM_MOUSEMOVE; вызывается, когда курсор мыши передвигается по клиентской области 
 WM_LBUTTONUP; вызывается, когда кнопка мыши отпушена в клиентской области 
 WM_NCLBUTTONUP; вызывается, когда кнопка мыши отпушена в не клиентской области 
 WM_NCLBUTTONDBLCLK; вызывается при двойном щелчке мышкой в не клиентской области 
Приведённый ниже код модифицирован, чтобы избавиться от нежелательного мерцания кнопки 
будем использовать следующие переменные: 
h1: THandle 	хэндл контекста устройства всего окна, включая не клиентскую область.
pressed: Boolean 	индикатор, показывающий, нажата кнопка или нет.
focuslost: Boolean	индикатор, показывающий, находится ли фокус на кнопке или нет.
rec: TRect 	размер кнопки.
type 
 TForm1 = class(TForm) 
 procedure FormPaint(Sender: TObject); 
 procedure FormResize(Sender: TObject); 
 procedure FormCreate(Sender: TObject); 
 private 
 { Private declarations } 
 public 
 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 WMMOVE(var msg: TMessage); message WM_MOUSEMOVE; 
 procedure WMLBUTTONUP(var msg: TMessage); message WM_LBUTTONUP; 
 procedure WMNCMOUSEUP(var msg: TMessage); message WM_NCLBUTTONUP; 
 procedure WNCLBUTTONDBLCLICK(var msg: TMessage); message WM_NCLBUTTONDBLCLK; 
 end; 
var 
 Form1: TForm1; 
 h1: THandle; 
 pressed: Boolean; 
 focuslost: Boolean; 
 rec: TRect;
 
implementation 
{$R *.DFM} 
procedure TForm1.WMLBUTTONUP(var msg: TMessage); 
begin
 pressed := False; 
 InvalidateRect(Form1.Handle, @rec, True); 
 inherited; 
end; 
procedure TForm1.WMMOVE(var msg: TMessage); 
var
 tmp: Boolean 
begin 
 tmp := focuslost; 
 focuslost := True; 
 if tmp <> focuslost then 
 InvalidateRect(Form1.Handle, @rec, True); 
 inherited; 
end; 
procedure TForm1.WMNCMOUSEMOVE(var msg: TMessage); 
var 
 pt1: TPoint; 
 tmp: Boolean; 
begin 
 tmp := focuslost; 
 pt1.x := msg.LParamLo - Form1.Left; 
 pt1.y := msg.LParamHi - Form1.Top; 
 if not(PtInRect(rec, pt1)) then 
 focuslost := True 
 else 
 focuslost := False; 
 if tmp <> focuslost then 
 InvalidateRect(Form1.Handle, @rec, True); 
end; 
procedure TForm1.WNCLBUTTONDBLCLICK(var msg: TMessage); 
var
 pt1: TPoint; 
begin 
 pt1.x := msg.LParamLo - Form1.Left; 
 pt1.y := msg.LParamHi - Form1.Top; 
 if not(PtInRect(rec, pt1)) then 
 inherited; 
end; 
procedure TForm1.WMNCMOUSEUP(var msg: TMessage); 
var 
 pt1: TPoint; 
begin 
 pt1.x := msg.LParamLo - Form1.Left; 
 pt1.y := msg.LParamHi - Form1.Top; 
 if (PtInRect(rec, pt1)) and (focuslost = false) then 
 begin 
 pressed:=false; 
 { 
 enter your code here when the button is clicked 
 } 
 InvalidateRect(Form1.Handle, @rec, True); 
 end 
 else 
 begin 
 pressed := False; 
 focuslost := True; 
 inherited; 
 end; 
end; 
procedure TForm1.WMNCMOUSEDOWN(var msg: TMessage); 
var
 pt1: TPoint; 
begin 
 pt1.x := msg.LParamLo - Form1.Left; 
 pt1.y := msg.LParamHi - Form1.Top; 
 if PtInRect(rec, pt1) then 
 begin 
 pressed := True; 
 InvalidateRect(Form1.Handle, @rec, True); 
 end 
 else 
 begin 
 Form1.Paint; 
 inherited; 
 end; 
end; 
procedure TForm1.WMNCACTIVATE(var msg: TMessage); 
begin 
 InvalidateRect(Form1.Handle, @rec, True); 
 inherited; 
end; 
procedure TForm1.WMNCPAINT(var msg: TMessage); 
begin 
 InvalidateRect(Form1.Handle, @rec, True); 
 inherited; 
end; 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
 h1 := GetWindowDC(Form1.Handle); 
 rec.Left := Form1.width-75; 
 rec.Top := 6; 
 rec.Right := Form1.Width-60; 
 rec.Bottom := 20; 
 SelectObject(h1, GetStockObject(ltgray_BRUSH)); 
 Rectangle(h1, rec.Left, rec.Top, rec.Right, rec.Bottom); 
 if (pressed = False) or (focuslost = True) then 
 DrawEdge(h1, rec, EDGE_RAISED, BF_RECT) 
 else if (pressed = true) and (focuslost = false) then 
 DrawEdge(h1, rec, EDGE_SUNKEN, BF_RECT); 
 ReleaseDC(Form1.Handle, h1); 
end; 
procedure TForm1.FormResize(Sender: TObject); 
begin 
 Form1.Paint; 
end; 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
 rec.Left := 0; 
 rec.Top := 0; 
 rec.Bottom := 0; 
 rec.Right := 0; 
end; 
Комментарии специалистов: 
Дата: 25 Августа 2000г.
InvalidateRect на событие Resize ничего не даёт. Но даже без него
кнопка всё равно моргает при Resize формы... Надо ещё где-то убрать
Для рисования кнопок на заголовке окна лучше пользоваться
DrawFrameControl а не DrawEdge... Так и с не серыми настройками
интерфейса всё правильно будет. Да и проще так.
Названия функций, констант и т.п лучше писать так, как они в описаниях
даются, а не подряд маленькими буквами. Особенно для публикации. Так
оно и читается по большей части лучше, и в С такая привычка Вам не
помешает...
Сравнивать логическое значение с логической константой чтоб получить
логическое значение глупо, так как логическое значение у Вас уже есть.
то есть вместо
 if (pressed = true) and (focuslost = false)
лучше писать
 if Pressed and not FocusLost
Для конструирования прямоугольников и точек из координат есть две
простые функции Rect и Point.
В общем Ваша процедура FormPaint может выглядеть так:
procedure TMainForm.FormPaint(Sender: TObject);
var 
 h1: THandle;
begin
 h1 := GetWindowDC(MainForm.Handle);
 rec := Rect(MainForm.Width-75, 6, MainForm.Width-60, 20);
 if Pressed and not FocusLost then 
 DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_PUSHED)
 else 
 DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH);
 ReleaseDC(MainForm.Handle, h1);
end;
Но вообще-то рисовать эту кнопку надо только при WM_NCPAINT, а не
всегда... И вычислять координаты по другому... Вдруг размер элементов
заголовка у юзера в системе не стандартный? А это просто настраивается...
Source: Взято из http://forum.sources.ru
ID: 00476
----
Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на Caption Bar.
Пример.
unit Main;
interface
uses
 Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
 TForm1 = class(TForm)
 procedure FormResize(Sender: TObject);
 private
 CaptionBtn: TRect;
 procedure DrawCaptButton;
 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;
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
implementation
const
 htCaptionBtn = htSizeLast + 1;
{$R *.DFM}
procedure TForm1.DrawCaptButton;
var
 xFrame, yFrame, xSize, ySize: Integer;
 R: TRect;
begin
 //Dimensions of Sizeable Frame
 xFrame := GetSystemMetrics(SM_CXFRAME);
 yFrame := GetSystemMetrics(SM_CYFRAME);
 //Dimensions of Caption Buttons
 xSize := GetSystemMetrics(SM_CXSIZE);
 ySize := GetSystemMetrics(SM_CYSIZE);
 //Define the placement of the new caption button
 CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
 yFrame + 2, xSize - 2, ySize - 4);
 //Get the handle to canvas using Form's device context
 Canvas.Handle := GetWindowDC(Self.Handle);
 Canvas.Font.Name := 'Symbol';
 Canvas.Font.Color := clBlue;
 Canvas.Font.Style := [fsBold];
 Canvas.Pen.Color := clYellow;
 Canvas.Brush.Color := clBtnFace;
 try
 DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
 //Define a smaller drawing rectangle within the button
 R := Bounds(Width - xFrame - 4 * xSize + 2,
 yFrame + 3, xSize - 6, ySize - 7);
 with CaptionBtn do
 Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
 finally
 ReleaseDC(Self.Handle, Canvas.Handle);
 Canvas.Handle := 0;
 end;
end;
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
begin
 inherited;
 DrawCaptButton;
end;
procedure TForm1.WMNCActivate(var Msg: TWMNCActivate);
begin
 inherited;
 DrawCaptButton;
end;
procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
 inherited;
 DrawCaptButton;
end;
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
 inherited;
 with Msg do
 if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
 Result := htCaptionBtn;
end;
procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
 inherited;
 if (Msg.HitTest = htCaptionBtn) then
 ShowMessage('You hit the button on the caption bar');
end;
procedure TForm1.FormResize(Sender: TObject);
begin
 // Force a redraw of caption bar if form is resized
 Perform(WM_NCACTIVATE, Word(Active), 0);
end;
end.
Source: http://dmitry9.nm.ru/info/
ID: 00477
----
Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.
Совместимость: Delphi 3.x (или выше)
type
 TFrmMainForm = class(TForm)
 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; 
 end;
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); 
begin
 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; // Вы можете изменить бэкграунд подсказки
end;
Source: Взято из http://forum.sources.ru
ID: 00478