Author: Tomas Rutkauskas
How to create a status bar that displays the system's time, date and keyboard status
Answer:
1 unit Status;
2
3 interface
4
5 uses
6 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
7 Forms, Dialogs, ExtCtrls, Menus, Gauges;
8
9 type
10 TStatus = class(TCustomPanel)
11 private
12 FDate: Boolean;
13 FKeys: Boolean;
14 FTime: Boolean;
15 FResources: Boolean;
16 DateTimePanel: TPanel;
17 ResPanel: TPanel;
18 ResGauge: TGauge;
19 CapPanel: TPanel;
20 NumPanel: TPanel;
21 InsPanel: TPanel;
22 HelpPanel: TPanel;
23 UpdateWidth: Boolean;
24 FTimer: TTimer;
25 procedure SetDate(A: Boolean);
26 procedure SetKeys(A: Boolean);
27 procedure SetTime(A: Boolean);
28 procedure SetResources(A: Boolean);
29 procedure SetCaption(A: string);
30 function GetCaption: string;
31 procedure CMFontChanged(var message: TMessage); message CM_FONTCHANGED;
32 public
33 constructor Create(AOwner: TComponent); override;
34 destructor Destroy; override;
35 procedure SetupPanelFields(ThePanel: TPanel);
36 procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
37 procedure UpdateStatusBar(Sender: TObject);
38 published
39 property ShowDate: Boolean read FDate write SetDate default True;
40 property ShowKeys: Boolean read FKeys write SetKeys default True;
41 property ShowTime: Boolean read FTime write SetTime default True;
42 property ShowResources: Boolean read FResources write SetResources default True;
43 property BevelInner;
44 property BevelOuter;
45 property BevelWidth;
46 property BorderStyle;
47 property BorderWidth;
48 property Caption: string read GetCaption write SetCaption;
49 property Color;
50 property Ctl3D;
51 property DragCursor;
52 property DragMode;
53 property Enabled;
54 property Font;
55 property ParentColor;
56 property ParentCtl3d;
57 property ParentFont;
58 property ParentShowHint;
59 property PopUpMenu;
60 property ShowHint;
61 property Visible;
62 end;
63
64 procedure register;
65
66 implementation
67
68 procedure register;
69 begin
70 RegisterComponents('Additional', [TStatus]);
71 end;
72
73 procedure TStatus.SetupPanelFields(ThePanel: TPanel);
74 begin
75 with ThePanel do
76 begin
77 Alignment := taCenter;
78 Caption := '';
79 BevelInner := bvLowered;
80 BevelOuter := bvNone;
81 {Set all these true so they reflect the settings of the TStatus}
82 ParentColor := True;
83 ParentFont := True;
84 ParentCtl3D := True;
85 end;
86 end;
87
88 procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
89 begin
90 SetupPanelFields(ThePanel);
91 with ThePanel do
92 begin
93 Width := Canvas.TextWidth(WidthMask);
94 Align := alRight;
95 end;
96 end;
97
98 constructor TStatus.Create(AOwner: TComponent);
99 begin
100 inherited Create(AOwner);
101 Parent := TWinControl(AOwner);
102 FTime := True;
103 FDate := True;
104 FKeys := True;
105 FResources := True;
106 {Force the status bar to be aligned bottom}
107 Align := alBottom;
108 Height := 19;
109 BevelInner := bvNone;
110 BevelOuter := bvRaised;
111 {When UpdateWidth is set TRUE, status bar will recalculate panel widths once}
112 UpdateWidth := True;
113 Locked := True;
114 TabOrder := 0;
115 ;
116 TabStop := False;
117 Font.Name := 'Arial';
118 Font.Size := 8;
119 {Create the panel that will hold the date and time}
120 DateTimePanel := TPanel.Create(Self);
121 DateTimePanel.Parent := Self;
122 SetupPanel(DateTimePanel, ' 00/00/00 00:00:00 am ');
123 {Create the panel that will hold the resources graph}
124 ResPanel := TPanel.Create(Self);
125 ResPanel.Parent := Self;
126 SetupPanel(ResPanel, ' ');
127 {Create the 2 Gauges that will reside within the Resource Panel}
128 ResGauge := TGauge.Create(Self);
129 ResGauge.Parent := ResPanel;
130 ResGauge.Align := alClient;
131 ResGauge.ParentFont := True;
132 ResGauge.BackColor := Color;
133 ResGauge.ForeColor := clLime;
134 ResGauge.BorderStyle := bsNone;
135 {Create the panel that will hold the CapsLock state}
136 CapPanel := TPanel.Create(Self);
137 CapPanel.Parent := Self;
138 SetupPanel(CapPanel, ' Cap ');
139 {Create the panel that will hold the NumLock state}
140 NumPanel := TPanel.Create(Self);
141 NumPanel.Parent := Self;
142 SetupPanel(NumPanel, ' Num ');
143 {Create the panel that will hold the Insert/Overwrite state}
144 InsPanel := TPanel.Create(Self);
145 InsPanel.Parent := Self;
146 SetupPanel(InsPanel, ' Ins ');
147 {Create the panel that will hold the status text}
148 HelpPanel := TPanel.Create(Self);
149 HelpPanel.Parent := Self;
150 SetupPanelFields(HelpPanel);
151 {Have the help panel consume all remaining space}
152 HelpPanel.Align := alClient;
153 HelpPanel.Alignment := taLeftJustify;
154 {This is the timer that will update the status bar at regular intervals}
155 FTimer := TTimer.Create(Self);
156 if FTimer <> nil then
157 begin
158 FTimer.OnTimer := UpdateStatusBar;
159 {Updates will occur twice a second}
160 FTimer.Interval := 500;
161 FTimer.Enabled := True;
162 end;
163 end;
164
165 destructor TStatus.Destroy;
166 begin
167 FTimer.Free;
168 HelpPanel.Free;
169 InsPanel.Free;
170 NumPanel.Free;
171 CapPanel.Free;
172 ResGauge.Free;
173 ResPanel.Free;
174 DateTimePanel.Free;
175 inherited Destroy;
176 end;
177
178 procedure TStatus.SetDate(A: Boolean);
179 begin
180 FDate := A;
181 UpdateWidth := True;
182 end;
183
184 procedure TStatus.SetKeys(A: Boolean);
185 begin
186 FKeys := A;
187 UpdateWidth := True;
188 end;
189
190 procedure TStatus.SetTime(A: Boolean);
191 begin
192 FTime := A;
193 UpdateWidth := True;
194 end;
195
196 procedure TStatus.SetResources(A: Boolean);
197 begin
198 FResources := A;
199 UpdateWidth := True;
200 end;
201
202 {When we set or get the TStatus caption, it is affecting the HelpPanel caption
203 instead}
204
205 procedure TStatus.SetCaption(A: string);
206 begin
207 HelpPanel.Caption := ' ' + A;
208 end;
209
210 function TStatus.GetCaption: string;
211 begin
212 GetCaption := HelpPanel.Caption;
213 end;
214
215 {This procedure sets the captions appropriately}
216
217 procedure TStatus.UpdateStatusBar(Sender: TObject);
218 begin
219 if ShowDate and ShowTime then
220 DateTimePanel.Caption := DateTimeToStr(Now)
221 else if ShowDate and not ShowTime then
222 DateTimePanel.Caption := DateToStr(Date)
223 else if not ShowDate and ShowTime then
224 DateTimePanel.Caption := TimeToStr(Time)
225 else
226 DateTimePanel.Caption := '';
227 if UpdateWidth then
228 with DateTimePanel do
229 if ShowDate or ShowTime then
230 Width := Canvas.TextWidth(' ' + Caption + ' ')
231 else
232 Width := 0;
233 if ShowResources then
234 begin
235 ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
236 if ResGauge.Progress < 20 then
237 ResGauge.ForeColor := clRed
238 else
239 ResGauge.ForeColor := clLime;
240 end;
241 if UpdateWidth then
242 if ShowResources then
243 ResPanel.Width := Canvas.TextWidth(' ')
244 else
245 ResPanel.Width := 0;
246 if ShowKeys then
247 begin
248 if (GetKeyState(vk_NumLock) and $01) <> 0 then
249 NumPanel.Caption := ' Num '
250 else
251 NumPanel.Caption := '';
252 if (GetKeyState(vk_Capital) and $01) <> 0 then
253 CapPanel.Caption := ' Cap '
254 else
255 CapPanel.Caption := '';
256 if (GetKeyState(vk_Insert) and $01) <> 0 then
257 InsPanel.Caption := ' Ins '
258 else
259 InsPanel.Caption := '';
260 end;
261 if UpdateWidth then
262 if ShowKeys then
263 begin
264 NumPanel.Width := Canvas.TextWidth(' Num ');
265 InsPanel.Width := Canvas.TextWidth(' Ins ');
266 CapPanel.Width := Canvas.TextWidth(' Cap ');
267 end
268 else
269 begin
270 NumPanel.Width := 0;
271 InsPanel.Width := 0;
272 CapPanel.Width := 0;
273 end;
274 UpdateWidth := False;
275 end;
276
277 {This allows font changes to be detected so the panels will be adjusted}
278
279 procedure TStatus.CMFontChanged(var message: TMessage);
280 begin
281 inherited;
282 UpdateWidth := True;
283 end;
284
285 end.
286
287 interface
288
289 implementation
290
291 end.
|
