Title: Adding a Custom Button to the Caption Bar with System Menu and Hint
Question: How to add a custom button to the caption bar with a System Menu and HINT!!!!
Answer:
That code can create a button to the caption bar, create a MenuItem in System menu and create a Hint to the button!
Just put the code above in your Unit and change the "FrmMainForm" to your Form name, and other small things like Text of Hint...
...
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
//*********************************************
//The button was clicked! Put you function here
//*********************************************
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;
//*********************************************
//The button was clicked! Put you function here
//*********************************************
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);
//It make a square button, but if you want a different button
//just change that var to your width.
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.Handle, 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; //You can change the background color of the Hint
...