Добавляем кнопку в заголовок окна

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: Tercio Ferdinando

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

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

Текст примера

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

{/codecitation}

Добавить комментарий