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

  • Автор темы sailor
  • Дата начала
Статус
Закрыто для дальнейших ответов.
S

sailor

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

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

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

Vagor.ini

#2
sailor
На окне реально уже нет места для кнопочки, а эта синя полоса содержит много бесполезно используемого места.
Прикольно:)

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

Код:
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.
 

admin

Well-known member
08.08.2003
2 754
0
#3
sailor
Есть компонент caption button (платный :) Если надо могу кинуть последнюю версию. Там всё что хош делает с заголовком окна.
 
Статус
Закрыто для дальнейших ответов.