Delphi: Как добавить кнопочку на titlebar?

Тема в разделе "Delphi - Система", создана пользователем sailor, 3 дек 2003.

Статус темы:
Закрыта.
  1. sailor

    sailor Гость

    Titlebar - сверху на любом окошке такая синяя полосочка сверху

    В общем, справа на ней надо добавить кнопочку которая нужна для оповещения прихода новой почты в системе (как на руборде сделано "у вас новая почта" - мигает конвертик... так мне что-то похожее надо сделать).

    На окне реально уже нет места для кнопочки, а эта синя полоса содержит много бесполезно используемого места.
     
  2. Vagor.ini

    Vagor.ini Гость

    sailor
    Прикольно:)

    Лови, нашел в залежах:), сам не пробовал...

    Код (Text):
    unit Unit1;

    interface

    uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    ComCtrls, ExtCtrls, StdCtrls;

    const
    wm_BtnClk = wm_User + 111;{Определяем своё сообщение}

    type
    TForm1 = class(TForm)
     procedure FormDestroy(Sender: TObject);
    private
     { Private declarations }
     R: TRect;{Переменная для обозначения прямоугольной области кнопки}
     Press: Boolean;
     procedure WmNcPaint(var Msg: TWmNcPaint); message wm_NcPaint;
     procedure WMNcActivate(var msg: TwmncActivate); message wm_NcActivate;
     procedure WmNcLButtonDown( var Msg: TWMNCLBUTTONDOWN); message Wm_NCLbuttonDown;
     procedure wmnchittest(var Msg: TWMncHITTEST); message wm_NcHittest;
     procedure wmSize(var Msg: TMessage); message wm_Size;
     procedure wmncLButtonUp(var msg: TWMncLBUTTONUP); message wm_NclButtonUp;
     procedure wmLbuttonUp(var Msg: TMessage); message wm_LbuttonUp;
     procedure wmBtnClk(var msg: TMessage); message wm_BtnClk;
    public
     { Public declarations }
     procedure DrawBtn;
    end;

    var
    Form1: TForm1;

    implementation

    {$R *.DFM}

    { TForm1 }

    procedure TForm1.WmNcPaint(var Msg: TWmNcPaint);
    begin
    inherited;
    Drawbtn;{При перерисовке окна прорисовываем кнопку}
    end;

    procedure TForm1.DrawBtn;{Код прорисовки кнопки}
    var
    WDc: HDc;
    Cx, Cy: Integer;
    XFrame, Yframe: Integer;
    begin
    {Получаем контекст нашего окна, снимаем мерки с оконных размеров,
    вычисляем положение нашей кнопки и прорисовываем её в зависимости
    от того нажата ли кнопка мыши над ней}
    WDc := GetWindowDc(Handle);
    Cx := GetSystemMetrics(SM_CXSize);
    Cy := GetSystemMetrics(SM_CYSize);
    xFrame := GetSystemMetrics(SM_CXFrame);
    yFrame := GetSystemMetrics(SM_CYFrame);
    R := Bounds(Width - xFrame - 4*Cx + 2, yFrame + 2, Cx - 2, Cy - 4);
    if Press then
     DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH or DFCS_PUSHED)
    else
     DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH);
    ReleaseDc(Handle,WDC);
    end;

    procedure TForm1.WMNcActivate(var msg: TwmncActivate);
    begin
    inherited;
    DrawBtn;
    end;

    procedure TForm1.WmNcLButtonDown(var Msg: TWMNCLBUTTONDOWN);
    var
    pt: TPoint;
    begin
    inherited;
    drawbtn;
    pt := Point(msg.XCursor - Left,msg.YCursor - top);
    if PtInRect(R,pt) then
    begin
     Press := True;
     drawbtn;
    end;
    end;


    procedure TForm1.wmnchittest(var Msg: TWMncHITTEST);
    var
    pt: tpoint;
    begin
    inherited;
    pt :=Point(msg.XPos - Left, msg.YPos - Top);
    if PtinRect(r,pt) then
     msg.Result := htBorder;
    end;

    procedure TForm1.wmSize(var Msg: TMessage);
    begin
    inherited;
    RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT
     or RDW_INVALIDATE);
    end;

    procedure TForm1.wmncLButtonUp(var msg: TWMncLBUTTONUP);
    var
    pt: TPoint;
    begin
    inherited;
    pt := Point(msg.XCursor - Left,msg.YCursor - top);
    if PtInRect(R,pt) then
    begin
     Press := False;
     drawbtn;
     PostMessage(Handle,wm_btnClk,0,0);
    end;
    end;

    procedure TForm1.wmLbuttonUp(var Msg: TMessage);
    begin
    inherited;
    if Press then
    begin
     Press := False;
     DrawBtn;
    end;
    end;

    procedure TForm1.wmBtnClk(var msg: TMessage);
    begin
    {Объявили константу своего сообщения,
    посылаем его своему окну при отпускании кнопки мыши над новой кнопкой,
    а здесь обрабатываем своё сообщение}
    ShowMessage('Кнопка работает!!!');
    end;

    procedure TForm1.FormDestroy(Sender: TObject);
    begin
    RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT
     or RDW_INVALIDATE);
    end;

    end.
     
  3. admin

    admin Well-Known Member

    Регистрация:
    8 авг 2003
    Сообщения:
    2.811
    Симпатии:
    0
    sailor
    Есть компонент caption button (платный :) Если надо могу кинуть последнюю версию. Там всё что хош делает с заголовком окна.
     
Загрузка...
Статус темы:
Закрыта.

Поделиться этой страницей