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

Материал из DRKB

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

Чтобы добавить дополнительную кнопку, нам прийдётся создать обработчики для следующих событий:

 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