Добавляем дополнительную кнопку в заголовок формы
Материал из 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