Карта сайта Kansoftware
НОВОСТИУСЛУГИРЕШЕНИЯКОНТАКТЫ
Разработка программного обеспечения
KANSoftWare

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

Delphi , Программа и Интерфейс , Заголовок формы

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

Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на Caption Bar.

Пример.

Code:

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.

Источник: http://dmitry9.nm.ru/info/


Автор: Tercio Ferdinando Gaudencio Filho

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.

Совместимость: Delphi 3.x (или выше)

Code:

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

Взято из

http://forum.sources.ru

Вы хотите добавить кнопку в панель заголовка вашего формы в Delphi. Это возможно, но требует некоторых workaround, поскольку Delphi не имеет встроенной поддержки для этого.

Приведенный код - это пример, как достичь этого. Он использует различные сообщения Windows (например, WM_ NCPAINT, WM_NCACTIVATE и т.д.) для рисования прямоугольника, похожего на кнопку, и обработки событий мыши.

Вот некоторые ключевые точки:

  1. Процедура DrawCaptButton рисует кнопку в панели заголовка.
  2. Процедура WMNCPaint используется для перерисовки кнопки при изменении размера формы или других изменениях.
  3. Процедуры WMNCActivate, WMSetText и WMNCHitTest используются для обработки различных событий, связанных с активацией, текстом и тестированием нажатия на кнопку.
  4. Процедура WMNCLButtonDown обрабатывает событие нажатия мыши на кнопке.
  5. Процедура FormResize forcing перерисовки панели заголовка при изменении размера формы.

В ответ на ваш вопрос о том, как добавить дополнительную кнопку в панель заголовка, вы можете попробовать модифицировать переменную Rec в процедуре DrawCaptButton, чтобы позиционировать новую кнопку.

Например, вы можете добавить еще один прямоугольник к переменной Rec и нарисовать вторую кнопку внутри него. Вам также нужно будет обновить логику тестирования нажатия в процедуре WMNCHitTest, чтобы обработать новую кнопку.

Обратите внимание, что это только примерный код, и вам, вероятно, придется модифицировать его для соответствия вашим конкретным требованиям. Кроме того, помните, что добавление кнопок в панель заголовка может иметь неожиданные последствия, такие как нарушение функциональности системного меню или создание проблем с управлением окнами.

Вот пример модифицированной процедуры DrawCaptButton, которая добавляет еще одну кнопку:

procedure TForm1.DrawCaptButton;
var
  xFrame, yFrame, xSize, ySize: Integer;
  R: TRect;
begin
   // Размеры рамки для размера
  xFrame  := GetSystemMetrics(SM_ CXFRAME);
  yFrame  := GetSystemMetrics(SM_CYFRAME);

   // Размеры кнопок заголовка
  xSize  := GetSystemMetrics(SM_CXSIZELABEL);
  ySize  := GetSystemMetrics(SM_CYSIZELABEL);

   // Определение расположения новой кнопки заголовка
  Rec.Left  := Width - (2 * xFrame + xSize) + 1;
  Rec.Top  := yFrame + 1;
  Rec.Right := Rec.Left + xSize;
  Rec.Bottom := Rec.Top + ySize;

  Canvas.Handle := GetWindowDC(Handle);
   ...
end;

В этом примере я добавил еще один прямоугольник к переменной Rec и позиционировал его слегка смещенным от оригинальной кнопки. Вы можете изменить координаты, как вам нужно.

Помните обновить логику тестирования нажатия в процедуре WMNCHitTest, чтобы обработать новую кнопку:

procedure TForm1.WMNCActivate(var Msg: TMessage);
begin
  if PtInRect(Rec, Point(Msg.LParamLo - Left, Msg.LParamHi - Top)) then
     ...
end;

Это только примерный код, и вам, вероятно, придется модифицировать его для соответствия вашим конкретным требованиям.

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


Комментарии и вопросы


Ваше мнение или вопрос к статье в виде простого текста (Tag <a href=... Disabled). Все комментарии модерируются, модератор оставляет за собой право удалить непонравившейся ему комментарий.

заголовок

e-mail

Ваше имя

Сообщение

Введите код




Материалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта.



:: Главная :: Заголовок формы ::


реклама



©KANSoftWare (разработка программного обеспечения, создание программ, создание интерактивных сайтов), 2007
Top.Mail.Ru

Время компиляции файла: 2024-06-02 10:20:12
2024-07-13 06:39:47/0.0043199062347412/0