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

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 и FreePascal.

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

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

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

Время компиляции файла: 2024-04-24 22:55:34
2024-04-26 12:11:30/0.0072638988494873/2