Author: Tercio Ferdinando Gaudencio Filho
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
1 private
2 { Private declarations }
3
4 procedure WMNCPAINT(var msg: Tmessage); message WM_NCPAINT;
5 procedure WMNCACTIVATE(var msg: Tmessage); message WM_NCACTIVATE;
6 procedure WMNCMOUSEDOWN(var msg: Tmessage); message WM_NCLBUTTONDOWN;
7 procedure WMNCMOUSEMOVE(var Msg: TMessage); message WM_NCMOUSEMOVE;
8 procedure WMMOUSEMOVE(var Msg: TMessage); message WM_MOUSEMOVE;
9 procedure WMLBUTTONUP(var msg: Tmessage); message WM_LBUTTONUP;
10 procedure WNCLBUTTONDBLCLICK(var msg: Tmessage); message
11 WM_NCLBUTTONDBLCLK;
12 procedure WMNCRBUTTONDOWN(var msg: Tmessage); message WM_NCRBUTTONDOWN;
13 procedure WMNCHITTEST(var msg: Tmessage); message WM_NCHITTEST;
14 procedure WMSYSCOMMAND(var msg: Tmessage); message WM_SYSCOMMAND;
15
16 {...}
17
18 var
19 {...}
20 Pressed: Boolean;
21 FocusLost: Boolean;
22 Rec: TRect;
23 NovoMenuHandle: THandle;
24 PT1: TPoint;
25 FHintshow: Boolean;
26 FHint: THintWindow;
27 FHintText: string;
28 FHintWidth: Integer;
29
30 {...}
31
32
33 //------------------------------------------------------------------------------
34
35 procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage);
36 begin
37 if Msg.WParam = LongInt(NovoMenuHandle) then
38 //*********************************************
39 //The button was clicked! Put you function here
40 //*********************************************
41 inherited;
42 end;
43
44 //------------------------------------------------------------------------------
45
46 procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage);
47 var
48 Tmp: Boolean;
49 begin
50 if Pressed then
51 begin
52 Tmp := FocusLost;
53 PT1.X := Msg.LParamLo - FrmMainForm.Left;
54 PT1.Y := Msg.LParamHi - FrmMainForm.Top;
55 if PTInRect(Rec, PT1) then
56 FocusLost := False
57 else
58 FocusLost := True;
59 if FocusLost <> Tmp then
60 InvalidateRect(FrmMainForm.Handle, @Rec, True);
61 end;
62 inherited;
63 end;
64
65 //------------------------------------------------------------------------------
66
67 procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage);
68 var
69 Tmp: Boolean;
70 begin
71 ReleaseCapture;
72 Tmp := Pressed;
73 Pressed := False;
74 if Tmp and PTInRect(Rec, PT1) then
75 begin
76 InvalidateRect(FrmMainForm.Handle, @Rec, True);
77 FHintShow := False;
78 FHint.ReleaseHandle;
79 //*********************************************
80 //The button was clicked! Put you function here
81 //*********************************************
82 end
83 else
84 inherited;
85 end;
86
87 //------------------------------------------------------------------------------
88
89 procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg: TMessage);
90 begin
91 PT1.X := Msg.LParamLo - FrmMainForm.Left;
92 PT1.Y := Msg.LParamHi - FrmMainForm.Top;
93 if not PTInRect(Rec, PT1) then
94 inherited;
95 end;
96
97 //------------------------------------------------------------------------------
98
99 procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage);
100 begin
101 PT1.X := Msg.LParamLo - FrmMainForm.Left;
102 PT1.Y := Msg.LParamHi - FrmMainForm.Top;
103 if not PTInRect(Rec, PT1) then
104 inherited;
105 end;
106
107 //------------------------------------------------------------------------------
108
109 procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage);
110 begin
111 PT1.X := Msg.LParamLo - FrmMainForm.Left;
112 PT1.Y := Msg.LParamHi - FrmMainForm.Top;
113 FHintShow := False;
114 if PTInRect(Rec, PT1) then
115 begin
116 Pressed := True;
117 FocusLost := False;
118 InvalidateRect(FrmMainForm.Handle, @Rec, True);
119 SetCapture(TWinControl(FrmMainForm).Handle);
120 end
121 else
122 begin
123 FrmMainForm.Paint;
124 inherited;
125 end;
126 end;
127
128 //------------------------------------------------------------------------------
129
130 //That function Create a Hint
131
132 procedure TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage);
133 begin
134 PT1.X := Msg.LParamLo - FrmMainForm.Left;
135 PT1.Y := Msg.LParamHi - FrmMainForm.Top;
136 if PTInRect(Rec, PT1) then
137 begin
138 FHintWidth := FHint.Canvas.TextWidth(FHintText);
139 if (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then
140 FHint.ActivateHint(
141 Rect(
142 Mouse.CursorPos.X,
143 Mouse.CursorPos.Y + 20,
144 Mouse.CursorPos.X + FHintWidth + 10,
145 Mouse.CursorPos.Y + 35
146 ),
147 FHintText
148 );
149 FHintShow := True;
150 end
151 else
152 begin
153 FHintShow := False;
154 FHint.ReleaseHandle;
155 end;
156 end;
157
158 //------------------------------------------------------------------------------
159
160 procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage);
161 begin
162 FHintShow := False;
163 FHint.ReleaseHandle;
164 end;
165
166 //------------------------------------------------------------------------------
167
168 procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage);
169 begin
170 InvalidateRect(FrmMainForm.Handle, @Rec, True);
171 inherited;
172 end;
173
174 //------------------------------------------------------------------------------
175
176 procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage);
177 begin
178 InvalidateRect(FrmMainForm.Handle, @Rec, True);
179 inherited;
180 end;
181
182 //------------------------------------------------------------------------------
183
184 procedure TFrmMainForm.FormPaint(Sender: TObject);
185 var
186 Border3D_Y, Border_Thickness, Btn_Width,
187 Button_Width, Button_Height: Integer;
188 MyCanvas: TCanvas;
189 begin
190 MyCanvas := TCanvas.Create;
191 MyCanvas.Handle := GetWindowDC(FrmMainForm.Handle);
192 Border3D_Y := GetSystemMetrics(SM_CYEDGE);
193 Border_Thickness := GetSystemMetrics(SM_CYSIZEFRAME);
194 Button_Width := GetSystemMetrics(SM_CXSIZE);
195 Button_Height := GetSystemMetrics(SM_CYSIZE);
196
197 //It make a square button, but if you want a different button
198 //just change that var to your width.
199 Btn_Width := Border3D_Y + Border_Thickness + Button_Height - (2
200 * Border3D_Y) - 1;
201
202 Rec.Left := FrmMainForm.Width - (3 * Button_Width + Btn_Width);
203 Rec.Right := FrmMainForm.Width - (3 * Button_Width + 03);
204 Rec.Top := Border3D_Y + Border_Thickness - 1;
205 Rec.Bottom := Rec.Top + Button_Height - (2 * Border3D_Y);
206 FillRect(MyCanvas.Handle, Rec, HBRUSH(COLOR_BTNFACE + 1));
207 if not Pressed or Focuslost then
208 DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED, BF_SOFT or BF_RECT)
209 else if Pressed and not Focuslost then
210 DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN, BF_SOFT or
211 BF_RECT);
212
213 //It draw a the application icon to the button. Easy to change.
214 DrawIconEX(MyCanvas.Handle, Rec.Left + 4, Rec.Top + 3,
215 Application.Icon.Handle, 8, 8, 0, 0, DI_NORMAL);
216
217 MyCanvas.Free;
218 end;
219
220 {... }
221
222 procedure TFrmMainForm.FormCreate(Sender: TObject);
223
224 {... }
225
226 InsertMenu(GetSystemMenu(Handle, False), 4, MF_BYPOSITION +
227 MF_STRING, NovoMenuHandle, pchar('TEXT OF THE MENU'));
228 Rec := Rect(0, 0, 0, 0);
229 FHintText := 'Put the text of your Hint HERE';
230 FHint := THintWindow.Create(Self);
231 FHint.Color := clInfoBk;
232 //You can change the background color of the Hint
|
