Author: Tomas Rutkauskas
Is it possible for the position parameter to fill a vertically orientated
ProgressBar going down (rather than starting from its bottom and going up)? I want
to indicate negative values. Ideal would be Min = -negative value and Max =
+positive value with zero position in center and the fill would start from zero
center and go either up or down depending on value.
Answer:
Here's one with that capability:
1 unit W95meter;
2
3 {This component is a Windows 95 style progress meter. It is free and donated to
4 the public domain. I do claim copyright of this code and I hereby prohibit the sale
5 of the source or compiled code to anyone for any amount.
6
7 Modified 11/29/00 by Eddie Shipman
8
9 1. Added Direction Property to allow reverse fills.
10
11 Modified 10/15/97 by Eddie Shipman
12
13 1. Added a Max Value so Values over 100 can be used
14
15 2. Fixed the Invalidation of the control after properties are changed.
16
17 Modified 12/22/95 by John Newlin
18
19 1. Caught by Larry E. Tanner 70242,27. Decreasing the Value of the Percent property
20 would fail to clear the higher segments. Fixed.
21
22 2. Setting the EdgeStyle propety to St95None would not eliminate painting the edge
23 outline. Fixed.
24
25 by John Newlin CIS 71535,665}
26
27 interface
28
29 uses
30 WinTypes, WinProcs, Messages, SysUtils, Classes, Controls, Forms, Menus,
31 Graphics, Dialogs;
32
33 type
34 StyleType = (st95None, st95Lowered, st95Raised);
35 TDirection = (dirForward, dirReverse);
36 TW95Meter = class(TGraphicControl)
37 private
38 FAlign: TAlign;
39 FPercent: Integer;
40 FBackColor: TColor;
41 FSegColor: TColor;
42 FSegWidth: Integer;
43 FSegGap: Integer;
44 FMax: Integer;
45 FEdgeStyle: StyleType;
46 FDirection: TDirection;
47 procedure Initialize;
48 procedure SetPercent(Value: Integer);
49 procedure SetAlign(Value: TAlign);
50 procedure SetBackColor(Value: TColor);
51 procedure SetDirection(Value: TDirection);
52 procedure SetSegColor(Value: TColor);
53 procedure SetSegWidth(Value: Integer);
54 procedure SetSegGap(Value: Integer);
55 procedure SetMax(Value: Integer);
56 procedure SetStyle(Value: StyleType);
57 protected
58 procedure UpdateProgress;
59 procedure Paint; override;
60 procedure AdjustSize; dynamic;
61 procedure RequestAlign; dynamic;
62 public
63 constructor Create(AOwner: TComponent); override;
64 property Canvas;
65 function IntPercent(High, Low: Longint): Integer;
66 function RealPercent(High, Low: real): Integer;
67 published
68 property OnClick;
69 property OnDblClick;
70 property OnMouseDown;
71 property OnMouseMove;
72 property OnMouseUp;
73 property Cursor;
74 property Align: TAlign read FAlign write SetAlign default alNone;
75 property Direction: TDirection read FDirection write SetDirection default
76 dirForward;
77 property EdgeStyle: StyleType read FEdgeStyle write SetStyle default
78 st95Lowered;
79 property SegmentGap: Integer read FSegGap write SetSegGap default 2;
80 property SegmentWidth: Integer read FSegWidth write SetSegWidth default 8;
81 property SegmentColor: TColor read FSegColor write SetSegColor default
82 clActiveCaption;
83 property BackGroundColor: TColor read FBackColor write SetBackColor default
84 clBtnFace;
85 property Percent: Integer read FPercent write SetPercent default 0;
86 property Max: Integer read FMax write SetMax default 100;
87 property Width default 100;
88 property Height default 18;
89 end;
90
91 procedure register;
92
93 implementation
94
95 procedure register;
96 begin
97 RegisterComponents('Win32', [TW95Meter]);
98 end;
99
100 procedure TW95Meter.SetSegWidth(Value: Integer);
101 begin
102 if (Value > 0) and (Value <> FSegWidth) then
103 begin
104 FSegWidth := Value;
105 Invalidate;
106 end;
107 end;
108
109 procedure TW95Meter.SetMax(Value: Integer);
110 begin
111 if Value <> FMax then
112 begin
113 FMax := Value;
114 Invalidate;
115 end;
116 end;
117
118 procedure TW95Meter.SetSegGap(Value: Integer);
119 begin
120 if (Value > 0) and (Value <> FSegGap) then
121 begin
122 FSegGap := Value;
123 Invalidate;
124 end;
125 end;
126
127 procedure TW95Meter.SetBackColor(Value: TColor);
128 begin
129 if FBackColor <> Value then
130 begin
131 FBackColor := Value;
132 Invalidate;
133 end;
134 end;
135
136 procedure TW95Meter.SetSegColor(Value: TColor);
137 begin
138 if FSegColor <> Value then
139 begin
140 FSegColor := Value;
141 Invalidate;
142 end;
143 end;
144
145 procedure TW95Meter.SetPercent(Value: Integer);
146 var
147 bRefresh: boolean;
148 begin
149 if Value <> FPercent then
150 begin
151 if FPercent > Value then
152 bRefresh := true
153 else
154 bRefresh := false;
155 FPercent := Value;
156 if (Fpercent = 0) or (bRefresh = true) or (csDesigning in ComponentState) then
157 Invalidate;
158 UpdateProgress;
159 end;
160 end;
161
162 procedure TW95Meter.SetStyle(Value: StyleType);
163 begin
164 if Value <> FEdgeStyle then
165 begin
166 FEdgeStyle := Value;
167 Invalidate;
168 end;
169 end;
170
171 procedure TW95Meter.Initialize;
172 begin
173 Width := 100;
174 Height := 18;
175 FPercent := 0;
176 FBackColor := clBtnFace;
177 FSegColor := clActiveCaption;
178 FSegWidth := 8;
179 FSegGap := 2;
180 FEdgeStyle := st95Lowered;
181 FMax := 100;
182 FDirection := dirForward;
183 end;
184
185 constructor TW95Meter.Create(AOwner: TComponent);
186 begin
187 inherited Create(AOwner);
188 Initialize;
189 end;
190
191 procedure TW95Meter.UpdateProgress;
192 var
193 x1, y1, x2, y2, max: Integer;
194 bg: TColor;
195
196 procedure DoHorizontalF;
197 var
198 i: Integer;
199 begin
200 x1 := 4;
201 x2 := x1 + FSegWidth;
202 y1 := 4;
203 y2 := Height - 4;
204 max := Width div (FSegWidth + FSegGap);
205 Max := round(max * (FPerCent / FMax));
206 for i := 1 to Max do
207 begin
208 with canvas do
209 begin
210 if x2 <= width - 4 then
211 Rectangle(x1, y1, x2, y2);
212 x1 := x1 + FSegWidth + FSegGap;
213 x2 := x1 + FSegWidth;
214 end;
215 end;
216 end;
217
218 procedure DoVerticalF;
219 var
220 i, h: Integer;
221 begin
222 h := height;
223 x1 := 4;
224 x2 := Width - 4;
225 y1 := Height - (FSegWidth + 4);
226 y2 := Height - 4;
227 max := Height div (FSegWidth + FSegGap);
228 max := round(max * (FPercent / FMax));
229 for i := 1 to max do
230 begin
231 with canvas do
232 begin
233 if y1 >= 4 then
234 Rectangle(x1, y1, x2, y2);
235 y1 := y1 - (FSegWidth + FSegGap);
236 y2 := y1 + FsegWidth;
237 end;
238 end;
239 end;
240
241 procedure DoHorizontalR;
242 var
243 i: Integer;
244 begin
245 x1 := Width - 4;
246 x2 := x1 - FSegWidth;
247 y1 := 4;
248 y2 := Height - 4;
249 max := Width div (FSegWidth + FSegGap);
250 Max := round(max * (FPerCent / FMax));
251 for i := 1 to Max do
252 begin
253 with canvas do
254 begin
255 if x2 <= width - 4 then
256 Rectangle(x1, y1, x2, y2);
257 x1 := x1 - FSegWidth - FSegGap;
258 x2 := x1 - FSegWidth;
259 end;
260 end;
261 end;
262
263 procedure DoVerticalR;
264 var
265 i: Integer;
266 begin
267 x1 := 4;
268 x2 := Width - 4;
269 y1 := 4;
270 y2 := 4 + FSegWidth;
271 max := Height div (FSegWidth + FSegGap);
272 max := round(max * (FPercent / FMax));
273 for i := 1 to max do
274 begin
275 with canvas do
276 begin
277 if y1 >= 4 then
278 Rectangle(x1, y1, x2, y2);
279 y1 := y1 + (FSegWidth + FSegGap);
280 y2 := y1 + FSegWidth;
281 end;
282 end;
283 end;
284
285 begin
286 canvas.pen.color := FSegColor;
287 canvas.brush.color := FsegColor;
288 case FDirection of
289 dirForward:
290 begin
291 if Width > Height then
292 DoHorizontalF
293 else
294 DoVerticalF;
295 end;
296 dirReverse:
297 begin
298 if Width > Height then
299 DoHorizontalR
300 else
301 DoVerticalR;
302 end;
303 end;
304 end;
305
306 procedure TW95Meter.Paint;
307 begin
308 with Canvas do
309 begin
310 Brush.Color := FBackColor;
311 if FEdgeStyle = st95none then
312 begin
313 Pen.Width := 0;
314 Pen.Color := FBackColor;
315 Rectangle(0, 0, width, height);
316 if FPercent > 0 then
317 UpdateProgress;
318 exit;
319 end;
320 pen.Width := 2;
321 if FEdgeStyle = st95Lowered then
322 pen.color := clgray
323 else
324 pen.color := clWhite;
325 moveto(0, height);
326 lineto(0, 0);
327 lineto(width - 1, 0);
328 if FEdgeStyle = st95Lowered then
329 pen.color := clWhite
330 else
331 pen.color := clGray;
332 lineto(width - 1, height - 1);
333 lineto(0, height - 1);
334 Pen.Width := 0;
335 Brush.Color := FBackColor;
336 Pen.Color := FBackColor;
337 Rectangle(1, 1, Width - 1, Height - 1);
338 if FPercent > 0 then
339 UpdateProgress;
340 end;
341 end;
342
343 function TW95Meter.RealPercent(High, Low: Real): Integer;
344 begin
345 result := 0;
346 if High = 0.0 then
347 exit;
348 Result := Round((Low / High) * FMax);
349 end;
350
351 function TW95Meter.IntPercent(High, Low: Longint): Integer;
352 begin
353 result := 0;
354 if High = 0 then
355 exit;
356 Result := Round((low / high) * FMax);
357 end;
358
359 procedure TW95Meter.SetAlign(Value: TAlign);
360 var
361 OldAlign: TAlign;
362 begin
363 if FAlign <> Value then
364 begin
365 OldAlign := FAlign;
366 FAlign := Value;
367 if not (csLoading in ComponentState) and (not (csDesigning in ComponentState) or
368 (Parent <> nil)) then
369 if ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and
370 not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient])
371 then
372 SetBounds(Left, Top, Height, Width)
373 else
374 AdjustSize;
375 end;
376 end;
377
378 procedure TW95Meter.AdjustSize;
379 begin
380 if not (csLoading in ComponentState) then
381 SetBounds(Left, Top, Width, Height);
382 end;
383
384 procedure TW95Meter.RequestAlign;
385 begin
386 { if Parent <> nil then Parent.AlignControl(Self); }
387 end;
388
389 procedure TW95Meter.SetDirection(Value: TDirection);
390 begin
391 if Value <> FDirection then
392 begin
393 FDirection := Value;
394 Invalidate;
395 end;
396 end;
397
398 end.
|
