source: trunk/Packages/Graphics32/GR32_RangeBars.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 52.2 KB
Line 
1unit GR32_RangeBars;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Graphics32
24 *
25 * The Initial Developer of the Original Code is
26 * Alex A. Denisov
27 *
28 * Portions created by the Initial Developer are Copyright (C) 2000-2009
29 * the Initial Developer. All Rights Reserved.
30 *
31 * Contributor(s):
32 * Andre Beckedorf <Andre@metaException.de>
33 * Marc Lafon
34 *
35 * ***** END LICENSE BLOCK ***** *)
36
37interface
38
39{$I GR32.inc}
40
41uses
42{$IFDEF FPC}
43 LCLIntf, LMessages, LCLType, Graphics, Controls, Forms, Dialogs, ExtCtrls,
44 {$IFDEF Windows} Windows, {$ENDIF}
45{$ELSE}
46 Windows, Messages, {$IFDEF INLININGSUPPORTED}Types,{$ENDIF}
47 Graphics, Controls, Forms, Dialogs, ExtCtrls,
48{$ENDIF}
49 SysUtils, Classes, GR32;
50
51type
52 TRBDirection = (drLeft, drUp, drRight, drDown);
53 TRBDirections = set of TRBDirection;
54 TRBZone = (zNone, zBtnPrev, zTrackPrev, zHandle, zTrackNext, zBtnNext);
55 TRBStyle = (rbsDefault, rbsMac);
56 TRBBackgnd = (bgPattern, bgSolid);
57 TRBGetSizeEvent = procedure(Sender: TObject; var Size: Integer) of object;
58
59 TArrowBar = class(TCustomControl)
60 private
61 FBackgnd: TRBBackgnd;
62 FBorderStyle: TBorderStyle;
63 FButtonSize: Integer;
64 FHandleColor: TColor;
65 FButtoncolor:TColor;
66 FHighLightColor:TColor;
67 FShadowColor:TColor;
68 FBorderColor:TColor;
69 FKind: TScrollBarKind;
70 FShowArrows: Boolean;
71 FShowHandleGrip: Boolean;
72 FStyle: TRBStyle;
73 FOnChange: TNotifyEvent;
74 FOnUserChange: TNotifyEvent;
75 procedure SetButtonSize(Value: Integer);
76 procedure SetHandleColor(Value: TColor);
77 procedure SetHighLightColor(Value: TColor);
78 procedure SetShadowColor(Value: TColor);
79 procedure SetButtonColor(Value: TColor);
80 procedure SetBorderColor(Value: TColor);
81 procedure SetKind(Value: TScrollBarKind);
82 procedure SetShowArrows(Value: Boolean);
83 procedure SetShowHandleGrip(Value: Boolean);
84 procedure SetStyle(Value: TRBStyle);
85 procedure SetBackgnd(Value: TRBBackgnd);
86{$IFDEF FPC}
87 procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
88 procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
89 procedure WMNCCalcSize(var Message: TLMNCCalcSize); message LM_NCCALCSIZE;
90 procedure WMEraseBkgnd(var Message: TLmEraseBkgnd); message LM_ERASEBKGND;
91{$IFDEF Windows}
92 procedure WMNCPaint(var Message: TWMNCPaint); message LM_NCPAINT;
93{$ENDIF}
94{$ELSE}
95 procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
96 procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
97 procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
98 procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
99 procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
100{$ENDIF}
101 protected
102 FGenChange: Boolean;
103 FDragZone: TRBZone;
104 FHotZone: TRBZone;
105 FTimer: TTimer;
106 FTimerMode: Integer;
107 FStored: TPoint;
108 FPosBeforeDrag: Single;
109 procedure DoChange; virtual;
110 procedure DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual;
111 procedure DoDrawHandle(R: TRect; Horz: Boolean; Pushed, Hot: Boolean); virtual;
112 procedure DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual;
113 function DrawEnabled: Boolean; virtual;
114 function GetBorderSize: Integer;
115 function GetHandleRect: TRect; virtual;
116 function GetButtonSize: Integer;
117 function GetTrackBoundary: TRect;
118 function GetZone(X, Y: Integer): TRBZone;
119 function GetZoneRect(Zone: TRBZone): TRect;
120 procedure MouseLeft; virtual;
121 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
122 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
123 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
124 procedure Paint; override;
125 procedure SetBorderStyle(Value: TBorderStyle); {$IFDEF FPC} override; {$ENDIF}
126 procedure StartDragTracking;
127 procedure StartHotTracking;
128 procedure StopDragTracking;
129 procedure StopHotTracking;
130 procedure TimerHandler(Sender: TObject); virtual;
131 public
132 constructor Create(AOwner: TComponent); override;
133 property Color default clScrollBar;
134 property Backgnd: TRBBackgnd read FBackgnd write SetBackgnd;
135 property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
136 property ButtonSize: Integer read FButtonSize write SetButtonSize default 0;
137 property HandleColor: TColor read FHandleColor write SetHandleColor default clBtnShadow;
138 property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace;
139 property HighLightColor: TColor read FHighLightColor write SetHighLightColor default clBtnHighlight;
140 property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;
141 property BorderColor: TColor read FBorderColor write SetBorderColor default clWindowFrame;
142 property Kind: TScrollBarKind read FKind write SetKind default sbHorizontal;
143 property ShowArrows: Boolean read FShowArrows write SetShowArrows default True;
144 property ShowHandleGrip: Boolean read FShowHandleGrip write SetShowHandleGrip;
145 property Style: TRBStyle read FStyle write SetStyle default rbsDefault;
146 property OnChange: TNotifyEvent read FOnChange write FOnChange;
147 property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange;
148 end;
149
150 TRBIncrement = 1..32768;
151
152 TCustomRangeBar = class(TArrowBar)
153 private
154 FCentered: Boolean;
155 FEffectiveWindow: Integer;
156 FIncrement: TRBIncrement;
157 FPosition: Single;
158 FRange: Integer;
159 FWindow: Integer;
160 function IsPositionStored: Boolean;
161 procedure SetPosition(Value: Single);
162 procedure SetRange(Value: Integer);
163 procedure SetWindow(Value: Integer);
164 protected
165 procedure AdjustPosition;
166 function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
167 MousePos: TPoint): Boolean; override;
168 function DrawEnabled: Boolean; override;
169 function GetHandleRect: TRect; override;
170 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
171 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
172 procedure TimerHandler(Sender: TObject); override;
173 procedure UpdateEffectiveWindow;
174 property EffectiveWindow: Integer read FEffectiveWindow;
175 public
176 constructor Create(AOwner: TComponent); override;
177 procedure Resize; override;
178 procedure SetParams(NewRange, NewWindow: Integer);
179 property Centered: Boolean read FCentered write FCentered;
180 property Increment: TRBIncrement read FIncrement write FIncrement default 8;
181 property Position: Single read FPosition write SetPosition stored IsPositionStored;
182 property Range: Integer read FRange write SetRange default 0;
183 property Window: Integer read FWindow write SetWindow default 0;
184 end;
185
186 TRangeBar = class(TCustomRangeBar)
187 published
188 property Align;
189 property Anchors;
190 property Constraints;
191 property Color;
192 property Backgnd;
193 property BorderStyle;
194 property ButtonSize;
195 property Enabled;
196 property HandleColor;
197 property ButtonColor;
198 property HighLightColor;
199 property ShadowColor;
200 property BorderColor;
201 property Increment;
202 property Kind;
203 property Range;
204 property Style;
205 property Visible;
206 property Window;
207 property ShowArrows;
208 property ShowHandleGrip;
209 property Position; // this should be located after the Range property
210 property OnChange;
211 property OnDragDrop;
212 property OnDragOver;
213 property OnEndDrag;
214 property OnMouseDown;
215 property OnMouseMove;
216 property OnMouseUp;
217 property OnMouseWheelUp;
218 property OnMouseWheelDown;
219 property OnStartDrag;
220 property OnUserChange;
221 end;
222
223 TCustomGaugeBar = class(TArrowBar)
224 private
225 FHandleSize: Integer;
226 FLargeChange: Integer;
227 FMax: Integer;
228 FMin: Integer;
229 FPosition: Integer;
230 FSmallChange: Integer;
231 procedure SetHandleSize(Value: Integer);
232 procedure SetMax(Value: Integer);
233 procedure SetMin(Value: Integer);
234 procedure SetPosition(Value: Integer);
235 procedure SetLargeChange(Value: Integer);
236 procedure SetSmallChange(Value: Integer);
237 protected
238 procedure AdjustPosition;
239 function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
240 MousePos: TPoint): Boolean; override;
241 function GetHandleRect: TRect; override;
242 function GetHandleSize: Integer;
243 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
244 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
245 procedure TimerHandler(Sender: TObject); override;
246 public
247 constructor Create(AOwner: TComponent); override;
248 property HandleSize: Integer read FHandleSize write SetHandleSize default 0;
249 property LargeChange: Integer read FLargeChange write SetLargeChange default 1;
250 property Max: Integer read FMax write SetMax default 100;
251 property Min: Integer read FMin write SetMin default 0;
252 property Position: Integer read FPosition write SetPosition;
253 property SmallChange: Integer read FSmallChange write SetSmallChange default 1;
254 property OnChange;
255 property OnUserChange;
256 end;
257
258 TGaugeBar = class(TCustomGaugeBar)
259 published
260 property Align;
261 property Anchors;
262 property Constraints;
263 property Color;
264 property Backgnd;
265 property BorderStyle;
266 property ButtonSize;
267 property Enabled;
268 property HandleColor;
269 property ButtonColor;
270 property HighLightColor;
271 property ShadowColor;
272 property BorderColor;
273 property HandleSize;
274 property Kind;
275 property LargeChange;
276 property Max;
277 property Min;
278 property ShowArrows;
279 property ShowHandleGrip;
280 property Style;
281 property SmallChange;
282 property Visible;
283 property Position;
284 property OnChange;
285 property OnDragDrop;
286 property OnDragOver;
287 property OnEndDrag;
288 property OnMouseDown;
289 property OnMouseMove;
290 property OnMouseUp;
291 property OnStartDrag;
292 property OnUserChange;
293 end;
294
295 { TArrowBarAccess }
296 { This class is designed to facilitate access to
297 properties of TArrowBar class when creating custom controls, which
298 incorporate TArrowBar. It allows controlling up to two arrow bars.
299 Master is used to read and write properties, slave - only to write.
300
301 Well, maybe it is not so useful itself, but it is a common ancestor
302 for TRangeBarAccess and TGaugeBarAccess classes, which work much the
303 same way.
304
305 When writing a new control, which uses TArrowBar, declare the bar as
306 protected member, TArrowBarAccess as published property, and assign
307 its Master to the arrow bar }
308 TArrowBarAccess = class(TPersistent)
309 private
310 FMaster: TArrowBar;
311 FSlave: TArrowBar;
312 function GetBackgnd: TRBBackgnd;
313 function GetButtonSize: Integer;
314 function GetColor: TColor;
315 function GetHandleColor: TColor;
316 function GetHighLightColor: TColor;
317 function GetButtonColor: TColor;
318 function GetBorderColor: TColor;
319 function GetShadowColor: TColor;
320 function GetShowArrows: Boolean;
321 function GetShowHandleGrip: Boolean;
322 function GetStyle: TRBStyle;
323 procedure SetBackgnd(Value: TRBBackgnd);
324 procedure SetButtonSize(Value: Integer);
325 procedure SetColor(Value: TColor);
326 procedure SetHandleColor(Value: TColor);
327 procedure SetShowArrows(Value: Boolean);
328 procedure SetShowHandleGrip(Value: Boolean);
329 procedure SetStyle(Value: TRBStyle);
330 procedure SetHighLightColor(Value: TColor);
331 procedure SetShadowColor(Value: TColor);
332 procedure SetButtonColor(Value: TColor);
333 procedure SetBorderColor(Value: TColor);
334 public
335 property Master: TArrowBar read FMaster write FMaster;
336 property Slave: TArrowBar read FSlave write FSlave;
337 published
338 property Color: TColor read GetColor write SetColor default clScrollBar;
339 property Backgnd: TRBBackgnd read GetBackgnd write SetBackgnd default bgPattern;
340 property ButtonSize: Integer read GetButtonSize write SetButtonSize default 0;
341 property HandleColor: TColor read GetHandleColor write SetHandleColor default clBtnShadow;
342 property ButtonColor:TColor read GetButtonColor write SetButtonColor default clBtnFace;
343 property HighLightColor:TColor read GetHighLightColor write SetHighLightColor default clBtnHighlight;
344 property ShadowColor:TColor read GetShadowColor write SetShadowColor default clBtnShadow;
345 property BorderColor:TColor read GetBorderColor write SetBorderColor default clWindowFrame;
346 property ShowArrows: Boolean read GetShowArrows write SetShowArrows default True;
347 property ShowHandleGrip: Boolean read GetShowHandleGrip write SetShowHandleGrip;
348 property Style: TRBStyle read GetStyle write SetStyle;
349 end;
350
351implementation
352
353uses
354 Math, GR32_XPThemes;
355
356const
357 OppositeDirection: array [TRBDirection] of TRBDirection = (drRight, drDown, drLeft, drUp);
358 tmScrollFirst = 1;
359 tmScroll = 2;
360 tmHotTrack = 3;
361
362function ClrLighten(C: TColor; Amount: Integer): TColor;
363var
364 R, G, B: Integer;
365begin
366{$IFDEF Windows}
367 if C < 0 then C := GetSysColor(C and $000000FF);
368{$ELSE}
369 C := ColorToRGB(C);
370{$ENDIF}
371 R := C and $FF + Amount;
372 G := C shr 8 and $FF + Amount;
373 B := C shr 16 and $FF + Amount;
374 if R < 0 then R := 0 else if R > 255 then R := 255;
375 if G < 0 then G := 0 else if G > 255 then G := 255;
376 if B < 0 then B := 0 else if B > 255 then B := 255;
377 Result := R or (G shl 8) or (B shl 16);
378end;
379
380function MixColors(C1, C2: TColor; W1: Integer): TColor;
381var
382 W2: Cardinal;
383begin
384 Assert(W1 in [0..255]);
385 W2 := W1 xor 255;
386{$IFDEF Windows}
387 if Integer(C1) < 0 then C1 := GetSysColor(C1 and $000000FF);
388 if Integer(C2) < 0 then C2 := GetSysColor(C2 and $000000FF);
389{$ELSE}
390 C1 := ColorToRGB(C1);
391 C2 := ColorToRGB(C2);
392{$ENDIF}
393 Result := Integer(
394 ((Cardinal(C1) and $FF00FF) * Cardinal(W1) +
395 (Cardinal(C2) and $FF00FF) * W2) and $FF00FF00 +
396 ((Cardinal(C1) and $00FF00) * Cardinal(W1) +
397 (Cardinal(C2) and $00FF00) * W2) and $00FF0000) shr 8;
398end;
399
400procedure DitherRect(Canvas: TCanvas; const R: TRect; C1, C2: TColor);
401var
402{$IFDEF FPC}
403 Brush: TBrush;
404 OldBrush: TBrush;
405{$ELSE}
406 B: TBitmap;
407 Brush: HBRUSH;
408{$ENDIF}
409begin
410 if GR32.IsRectEmpty(R) then Exit;
411{$IFDEF FPC}
412 Brush := TBrush.Create;
413 try
414 Brush.Color := ColorToRGB(C1);
415 if C1 <> C2 then
416 begin
417 Brush.Bitmap := Graphics.TBitmap.Create;
418 with Brush.Bitmap do
419 begin
420 Height := 2;
421 Width := 2;
422 Canvas.Pixels[0,0] := C1;
423 Canvas.Pixels[1,0] := C2;
424 Canvas.Pixels[0,1] := C2;
425 Canvas.Pixels[1,1] := C1;
426 end;
427 Brush.Color := ColorToRGB(C1);
428 end;
429 OldBrush := TBrush.Create;
430 try
431 OldBrush.Assign(Canvas.Brush);
432 Canvas.Brush.Assign(Brush);
433 Canvas.FillRect(R);
434 Canvas.Brush.Assign(OldBrush);
435 finally
436 OldBrush.Free;
437 end;
438 finally
439 if Assigned(Brush.Bitmap) then
440 Brush.Bitmap.Free;
441
442 Brush.Free;
443 end;
444{$ELSE}
445 if C1 = C2 then
446 Brush := CreateSolidBrush(ColorToRGB(C1))
447 else
448 begin
449 B := AllocPatternBitmap(C1, C2);
450 B.HandleType := bmDDB;
451 Brush := CreatePatternBrush(B.Handle);
452 end;
453 FillRect(Canvas.Handle, R, Brush);
454 DeleteObject(Brush);
455{$ENDIF}
456end;
457
458procedure DrawRectEx(Canvas: TCanvas; var R: TRect; Sides: TRBDirections; C: TColor);
459begin
460 if Sides <> [] then with Canvas, R do
461 begin
462 Pen.Color := C;
463 if drUp in Sides then
464 begin
465 MoveTo(Left, Top); LineTo(Right, Top); Inc(Top);
466 end;
467 if drDown in Sides then
468 begin
469 Dec(Bottom); MoveTo(Left, Bottom); LineTo(Right, Bottom);
470 end;
471 if drLeft in Sides then
472 begin
473 MoveTo(Left, Top); LineTo(Left, Bottom); Inc(Left);
474 end;
475 if drRight in Sides then
476 begin
477 Dec(Right); MoveTo(Right, Top); LineTo(Right, Bottom);
478 end;
479 end;
480end;
481
482procedure Frame3D(Canvas: TCanvas; var ARect: TRect; TopColor, BottomColor: TColor; AdjustRect: Boolean = True);
483var
484 TopRight, BottomLeft: TPoint;
485begin
486 with Canvas, ARect do
487 begin
488 Pen.Width := 1;
489 Dec(Bottom); Dec(Right);
490 TopRight.X := Right;
491 TopRight.Y := Top;
492 BottomLeft.X := Left;
493 BottomLeft.Y := Bottom;
494 Pen.Color := TopColor;
495 PolyLine([BottomLeft, TopLeft, TopRight]);
496 Pen.Color := BottomColor;
497 Dec(Left);
498 PolyLine([TopRight, BottomRight, BottomLeft]);
499 if AdjustRect then
500 begin
501 Inc(Top); Inc(Left, 2);
502 end
503 else
504 begin
505 Inc(Left); Inc(Bottom); Inc(Right);
506 end;
507 end;
508end;
509
510procedure DrawHandle(Canvas: TCanvas; R: TRect; Color: TColor;
511 Pushed, ShowGrip, IsHorz: Boolean; ColorBorder: TColor);
512var
513 CHi, CLo: TColor;
514 I, S: Integer;
515begin
516 CHi := ClrLighten(Color, 24);
517 CLo := ClrLighten(Color, -24);
518
519 Canvas.Brush.Color := ColorBorder;
520 FrameRect(Canvas.Handle, R, Canvas.Brush.Handle);
521
522 GR32.InflateRect(R, -1, -1);
523 if Pushed then Frame3D(Canvas, R, CLo, Color)
524 else Frame3D(Canvas, R, CHi, MixColors(ColorBorder, Color, 96));
525 Canvas.Brush.Color := Color;
526 Canvas.FillRect(R);
527
528 if ShowGrip then
529 begin
530 if Pushed then GR32.OffsetRect(R, 1, 1);
531 if IsHorz then
532 begin
533 S := R.Right - R.Left;
534 R.Left := (R.Left + R.Right) div 2 - 5;
535 R.Right := R.Left + 2;
536 Inc(R.Top); Dec(R.Bottom);
537
538 if S > 10 then Frame3D(Canvas, R, CHi, CLo, False);
539 Inc(R.Left, 3); Inc(R.Right, 3);
540 Frame3D(Canvas, R, CHi, CLo, False);
541 Inc(R.Left, 3); Inc(R.Right, 3);
542 Frame3D(Canvas, R, CHi, CLo, False);
543 Inc(R.Left, 3); Inc(R.Right, 3);
544 if S > 10 then Frame3D(Canvas, R, CHi, CLo, False);
545 end
546 else
547 begin
548 I := (R.Top + R.Bottom) div 2;
549 S := R.Bottom - R.Top;
550 R.Top := I - 1;
551 R.Bottom := I + 1;
552 Dec(R.Right);
553 Inc(R.Left);
554
555 GR32.OffsetRect(R, 0, -4);
556 if S > 10 then Frame3D(Canvas, R, CHi, CLo, False);
557
558 GR32.OffsetRect(R, 0, 3);
559 Frame3D(Canvas, R, CHi, CLo, False);
560
561 GR32.OffsetRect(R, 0, 3);
562 Frame3D(Canvas, R, CHi, CLo, False);
563
564 if S > 10 then
565 begin
566 GR32.OffsetRect(R, 0, 3);
567 Frame3D(Canvas, R, CHi, CLo, False);
568 end;
569 end;
570 end;
571end;
572
573procedure DrawArrow(Canvas: TCanvas; R: TRect; Direction: TRBDirection; Color: TColor);
574var
575 X, Y, Sz, Shift: Integer;
576begin
577 X := (R.Left + R.Right - 1) div 2;
578 Y := (R.Top + R.Bottom - 1) div 2;
579 Sz := (Min(X - R.Left, Y - R.Top)) * 3 div 4 - 1;
580 if Sz = 0 then Sz := 1;
581 if Direction in [drUp, drLeft] then Shift := (Sz + 1) * 1 div 3
582 else Shift := Sz * 1 div 3;
583 Canvas.Pen.Color := Color;
584 Canvas.Brush.Color := Color;
585 case Direction of
586 drUp:
587 begin
588 Inc(Y, Shift);
589 Canvas.Polygon([Point(X + Sz, Y), Point(X, Y - Sz), Point(X - Sz, Y)]);
590 end;
591 drDown:
592 begin
593 Dec(Y, Shift);
594 Canvas.Polygon([Point(X + Sz, Y), Point(X, Y + Sz), Point(X - Sz, Y)]);
595 end;
596 drLeft:
597 begin
598 Inc(X, Shift);
599 Canvas.Polygon([Point(X, Y + Sz), Point(X - Sz, Y), Point(X, Y - Sz)]);
600 end;
601 drRight:
602 begin
603 Dec(X, Shift);
604 Canvas.Polygon([Point(X, Y + Sz), Point(X + Sz, Y), Point(X, Y - Sz)]);
605 end;
606 end;
607end;
608
609const
610 FIRST_DELAY = 600;
611 SCROLL_INTERVAL = 100;
612 HOTTRACK_INTERVAL = 150;
613 MIN_SIZE = 17;
614
615{ TArrowBar }
616
617{$IFDEF FPC}
618procedure TArrowBar.CMEnabledChanged(var Message: TLMessage);
619{$ELSE}
620procedure TArrowBar.CMEnabledChanged(var Message: TMessage);
621{$ENDIF}
622begin
623 inherited;
624 Invalidate;
625end;
626
627{$IFDEF FPC}
628procedure TArrowBar.CMMouseLeave(var Message: TLMessage);
629{$ELSE}
630procedure TArrowBar.CMMouseLeave(var Message: TMessage);
631{$ENDIF}
632begin
633 MouseLeft;
634 inherited;
635end;
636
637constructor TArrowBar.Create(AOwner: TComponent);
638begin
639 inherited;
640 ControlStyle := ControlStyle - [csAcceptsControls, csDoubleClicks] + [csOpaque];
641 Width := 100;
642 Height := 16;
643 ParentColor := False;
644 Color := clScrollBar;
645 FTimer := TTimer.Create(Self);
646 FTimer.OnTimer := TimerHandler;
647 FShowArrows := True;
648 FBorderStyle := bsSingle;
649 FHandleColor := clBtnShadow;
650 FButtonColor := clBtnFace;
651 FHighLightColor := clBtnHighlight;
652 FShadowColor := clBtnShadow;
653 FBorderColor := clWindowFrame;
654 FShowHandleGrip := True;
655end;
656
657procedure TArrowBar.DoChange;
658begin
659 if Assigned(FOnChange) then FOnChange(Self);
660 if FGenChange and Assigned(FOnUserChange) then FOnUserChange(Self);
661end;
662
663procedure TArrowBar.DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean);
664const
665 EnabledFlags: array [Boolean] of Integer = (DFCS_INACTIVE, 0);
666 PushedFlags: array [Boolean] of Integer = (0, DFCS_PUSHED or DFCS_FLAT);
667 DirectionFlags: array [TRBDirection] of Integer = (DFCS_SCROLLLEFT, DFCS_SCROLLUP,
668 DFCS_SCROLLRIGHT, DFCS_SCROLLDOWN);
669{$IFDEF Windows}
670 DirectionXPFlags: array [TRBDirection] of Cardinal = (ABS_LEFTNORMAL,
671 ABS_UPNORMAL, ABS_RIGHTNORMAL, ABS_DOWNNORMAL);
672{$ENDIF}
673var
674 Edges: TRBDirections;
675{$IFDEF Windows}
676 Flags: Integer;
677{$ENDIF}
678begin
679 if Style = rbsDefault then
680 begin
681{$IFDEF FPC}
682{$IFNDEF Windows}
683 Canvas.Brush.Color := clButton;
684 Canvas.FillRect(R);
685 LCLIntf.DrawFrameControl(Canvas.Handle, R, DFC_BUTTON, 0);
686 InflateRect(R, -2, -2);
687
688 If not DrawEnabled then
689 begin
690 InflateRect(R, -1, -1);
691 OffsetRect(R, 1, 1);
692 DrawArrow(Canvas, R, Direction, clWhite);
693 OffsetRect(R, -1, -1);
694 DrawArrow(Canvas, R, Direction, clDisabledButtonText);
695 end
696 else
697 begin
698 If Pushed then OffsetRect(R, 1, 1);
699 DrawArrow(Canvas, R, Direction, clButtonText);
700 end;
701{$ENDIF}
702{$ENDIF}
703
704{$IFDEF Windows}
705 if USE_THEMES then
706 begin
707 Flags := DirectionXPFlags[Direction];
708 if not Enabled then Inc(Flags, 3)
709 else if Pushed then Inc(Flags, 2)
710 else if Hot then Inc(Flags);
711 DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, SBP_ARROWBTN, Flags, R, nil);
712 end
713 else
714 DrawFrameControl(Canvas.Handle, R, DFC_SCROLL,
715 DirectionFlags[Direction] or EnabledFlags[DrawEnabled] or PushedFlags[Pushed])
716{$ENDIF}
717 end
718 else
719 begin
720 Edges := [drLeft, drUp, drRight, drDown];
721 Exclude(Edges, OppositeDirection[Direction]);
722
723 if not DrawEnabled then
724 begin
725 DrawRectEx(Canvas, R, Edges, fShadowColor);
726 Canvas.Brush.Color := fButtonColor;
727 FillRect(Canvas.Handle, R, Canvas.Brush.Handle);
728 GR32.InflateRect(R, -1, -1);
729 GR32.OffsetRect(R, 1, 1);
730 DrawArrow(Canvas, R, Direction, fHighLightColor);
731 GR32.OffsetRect(R, -1, -1);
732 DrawArrow(Canvas, R, Direction, fShadowColor);
733 end
734 else
735 begin
736 DrawRectEx(Canvas, R, Edges, fBorderColor);
737 if Pushed then
738 begin
739 Canvas.Brush.Color := fButtonColor;
740 FillRect(Canvas.Handle, R, Canvas.Brush.Handle);
741 GR32.OffsetRect(R, 1, 1);
742 GR32.InflateRect(R, -1, -1);
743 end
744 else
745 begin
746 Frame3D(Canvas, R, fHighLightColor, fShadowColor, True);
747 Canvas.Brush.Color := fButtonColor;
748 FillRect(Canvas.Handle, R, Canvas.Brush.Handle);
749 end;
750 DrawArrow(Canvas, R, Direction, fBorderColor);
751 end;
752 end;
753end;
754
755procedure TArrowBar.DoDrawHandle(R: TRect; Horz, Pushed, Hot: Boolean);
756{$IFDEF Windows}
757const
758 PartXPFlags: array [Boolean] of Cardinal = (SBP_THUMBBTNVERT, SBP_THUMBBTNHORZ);
759 GripperFlags: array [Boolean] of Cardinal = (SBP_GRIPPERVERT, SBP_GRIPPERHORZ);
760var
761 Flags: Cardinal;
762{$ENDIF}
763begin
764 if GR32.IsRectEmpty(R) then Exit;
765 case Style of
766 rbsDefault:
767 begin
768{$IFDEF Windows}
769 if USE_THEMES then
770 begin
771 Flags := SCRBS_NORMAL;
772 if not Enabled then Inc(Flags, 3)
773 else if Pushed then Inc(Flags, 2)
774 else if Hot then Inc(Flags);
775 DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, PartXPFlags[Horz], Flags, R, nil);
776 if ShowHandleGrip then
777 DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, GripperFlags[Horz], 0, R, nil);
778 end
779 else
780 DrawEdge(Canvas.Handle, R, EDGE_RAISED, BF_RECT or BF_MIDDLE);
781{$ENDIF}
782 end;
783
784 rbsMac:
785 begin
786 DrawHandle(Canvas, R, HandleColor, Pushed, ShowHandleGrip, Horz, fBorderColor);
787 end;
788 end;
789end;
790
791procedure TArrowBar.DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean);
792{$IFDEF Windows}
793const
794 PartXPFlags: array [TRBDirection] of Cardinal =
795 (SBP_LOWERTRACKHORZ, SBP_LOWERTRACKVERT, SBP_UPPERTRACKHORZ, SBP_UPPERTRACKVERT);
796{$ENDIF}
797var
798{$IFDEF Windows}
799 Flags: Cardinal;
800{$ENDIF}
801 C: TColor;
802 Edges: set of TRBDirection;
803begin
804 if (R.Right <= R.Left) or (R.Bottom <= R.Top) then Exit;
805 if Style = rbsDefault then
806 begin
807{$IFDEF Windows}
808 if USE_THEMES then
809 begin
810 Flags := SCRBS_NORMAL;
811 if Pushed then Inc(Flags, 2);
812 DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, PartXPFlags[Direction], Flags, R, nil);
813 end
814 else
815{$ENDIF}
816 begin
817 if Pushed then DitherRect(Canvas, R, clWindowFrame, clWindowFrame)
818 else DitherRect(Canvas, R, clBtnHighlight, Color);
819 end;
820 end
821 else
822 with Canvas, R do
823 begin
824 if DrawEnabled then C := FBorderColor
825 else C := FShadowColor;
826 Edges := [drLeft, drUp, drRight, drDown];
827 Exclude(Edges, OppositeDirection[Direction]);
828 DrawRectEx(Canvas, R, Edges, C);
829 if Pushed then DitherRect(Canvas, R, fBorderColor,fBorderColor)
830 else if not GR32.IsRectEmpty(R) then with R do
831 begin
832 if DrawEnabled then
833 begin
834 Pen.Color := MixColors(fBorderColor, MixColors(fHighLightColor, Color, 127), 32);
835 case Direction of
836 drLeft, drUp:
837 begin
838 MoveTo(Left, Bottom - 1); LineTo(Left, Top); LineTo(Right, Top);
839 Inc(Top); Inc(Left);
840 end;
841 drRight:
842 begin
843 MoveTo(Left, Top); LineTo(Right, Top);
844 Inc(Top);
845 end;
846 drDown:
847 begin
848 MoveTo(Left, Top); LineTo(Left, Bottom);
849 Inc(Left);
850 end;
851 end;
852 if Backgnd = bgPattern then DitherRect(Canvas, R, fHighLightColor, Color)
853 else DitherRect(Canvas, R, Color, Color);
854 end
855 else
856 begin
857 Brush.Color := fButtonColor;
858 FillRect(R);
859 end;
860 end;
861 end;
862end;
863
864function TArrowBar.DrawEnabled: Boolean;
865begin
866 Result := Enabled;
867end;
868
869function TArrowBar.GetBorderSize: Integer;
870const
871 CSize: array [Boolean] of Integer = (0, 1);
872begin
873 Result := CSize[BorderStyle = bsSingle];
874end;
875
876function TArrowBar.GetButtonSize: Integer;
877var
878 W, H: Integer;
879begin
880 if not ShowArrows then Result := 0
881 else
882 begin
883 Result := ButtonSize;
884 if Kind = sbHorizontal then
885 begin
886 W := ClientWidth;
887 H := ClientHeight;
888 end
889 else
890 begin
891 W := ClientHeight;
892 H := ClientWidth;
893 end;
894 if Result = 0 then Result := Min(H, 32);
895 if Result * 2 >= W then Result := W div 2;
896 if Style = rbsMac then Dec(Result);
897 if Result < 2 then Result := 0;
898 end;
899end;
900
901function TArrowBar.GetHandleRect: TRect;
902begin
903 Result := Rect(0, 0, 0, 0);
904end;
905
906function TArrowBar.GetTrackBoundary: TRect;
907begin
908 Result := ClientRect;
909 if Kind = sbHorizontal then GR32.InflateRect(Result, -GetButtonSize, 0)
910 else GR32.InflateRect(Result, 0, -GetButtonSize);
911end;
912
913function TArrowBar.GetZone(X, Y: Integer): TRBZone;
914var
915 P: TPoint;
916 R, R1: TRect;
917 Sz: Integer;
918begin
919 Result := zNone;
920
921 P := Point(X, Y);
922 R := ClientRect;
923 if not GR32.PtInrect(R, P) then Exit;
924
925 Sz := GetButtonSize;
926 R1 := R;
927 if Kind = sbHorizontal then
928 begin
929 R1.Right := R1.Left + Sz;
930 if GR32.PtInRect(R1, P) then Result := zBtnPrev
931 else
932 begin
933 R1.Right := R.Right;
934 R1.Left := R.Right - Sz;
935 if GR32.PtInRect(R1, P) then Result := zBtnNext;
936 end;
937 end
938 else
939 begin
940 R1.Bottom := R1.Top + Sz;
941 if GR32.PtInRect(R1, P) then Result := zBtnPrev
942 else
943 begin
944 R1.Bottom := R.Bottom;
945 R1.Top := R.Bottom - Sz;
946 if GR32.PtInRect(R1, P) then Result := zBtnNext;
947 end;
948 end;
949
950 if Result = zNone then
951 begin
952 R := GetHandleRect;
953 P := Point(X, Y);
954 if GR32.PtInRect(R, P) then Result := zHandle
955 else
956 begin
957 if Kind = sbHorizontal then
958 begin
959 if (X > 0) and (X < R.Left) then Result := zTrackPrev
960 else if (X >= R.Right) and (X < ClientWidth - 1) then Result := zTrackNext;
961 end
962 else
963 begin
964 if (Y > 0) and (Y < R.Top) then Result := zTrackPrev
965 else if (Y >= R.Bottom) and (Y < ClientHeight - 1) then Result := zTrackNext;
966 end;
967 end;
968 end;
969end;
970
971function TArrowBar.GetZoneRect(Zone: TRBZone): TRect;
972const
973 CEmptyRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
974var
975 BtnSize: Integer;
976 Horz: Boolean;
977 R: TRect;
978begin
979 Horz := Kind = sbHorizontal;
980 BtnSize:= GetButtonSize;
981 case Zone of
982 zNone: Result := CEmptyRect;
983 zBtnPrev:
984 begin
985 Result := ClientRect;
986 if Horz then Result.Right := Result.Left + BtnSize
987 else Result.Bottom := Result.Top + BtnSize;
988 end;
989 zTrackPrev..zTrackNext:
990 begin
991 Result := GetTrackBoundary;
992 R := GetHandleRect;
993 if not DrawEnabled or GR32.IsRectEmpty(R) then
994 begin
995 R.Left := (Result.Left + Result.Right) div 2;
996 R.Top := (Result.Top + Result.Bottom) div 2;
997 R.Right := R.Left;
998 R.Bottom := R.Top;
999 end;
1000 case Zone of
1001 zTrackPrev:
1002 if Horz then Result.Right := R.Left
1003 else Result.Bottom := R.Top;
1004 zHandle:
1005 Result := R;
1006 zTrackNext:
1007 if Horz then Result.Left := R.Right
1008 else Result.Top := R.Bottom;
1009 end;
1010 end;
1011 zBtnNext:
1012 begin
1013 Result := ClientRect;
1014 if Horz then Result.Left := Result.Right - BtnSize
1015 else Result.Top := Result.Bottom - BtnSize;
1016 end;
1017 end;
1018end;
1019
1020procedure TArrowBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1021begin
1022 inherited;
1023 if Button <> mbLeft then Exit;
1024 FDragZone := GetZone(X, Y);
1025 Invalidate;
1026 FStored.X := X;
1027 FStored.Y := Y;
1028 StartDragTracking;
1029end;
1030
1031procedure TArrowBar.MouseLeft;
1032begin
1033 StopHotTracking;
1034end;
1035
1036procedure TArrowBar.MouseMove(Shift: TShiftState; X, Y: Integer);
1037var
1038 NewHotZone: TRBZone;
1039begin
1040 inherited;
1041 if (FDragZone = zNone) and DrawEnabled then
1042 begin
1043 NewHotZone := GetZone(X, Y);
1044 if NewHotZone <> FHotZone then
1045 begin
1046 FHotZone := NewHotZone;
1047 if FHotZone <> zNone then StartHotTracking;
1048 Invalidate;
1049 end;
1050 end;
1051end;
1052
1053procedure TArrowBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1054begin
1055 inherited;
1056 FDragZone := zNone;
1057 Invalidate;
1058 StopDragTracking;
1059end;
1060
1061procedure TArrowBar.Paint;
1062const
1063 CPrevDirs: array [Boolean] of TRBDirection = (drUp, drLeft);
1064 CNextDirs: array [Boolean] of TRBDirection = (drDown, drRight);
1065var
1066 BSize: Integer;
1067 ShowEnabled: Boolean;
1068 R, BtnRect, HandleRect: TRect;
1069 Horz, ShowHandle: Boolean;
1070begin
1071 R := ClientRect;
1072 Horz := Kind = sbHorizontal;
1073 ShowEnabled := DrawEnabled;
1074 BSize := GetButtonSize;
1075
1076 if ShowArrows then
1077 begin
1078 { left / top button }
1079 BtnRect := R;
1080 with BtnRect do if Horz then Right := Left + BSize else Bottom := Top + BSize;
1081 DoDrawButton(BtnRect, CPrevDirs[Horz], FDragZone = zBtnPrev, ShowEnabled, FHotZone = zBtnPrev);
1082
1083 { right / bottom button }
1084 BtnRect := R;
1085 with BtnRect do if Horz then Left := Right - BSize else Top := Bottom - BSize;
1086 DoDrawButton(BtnRect, CNextDirs[Horz], FDragZone = zBtnNext, ShowEnabled, FHotZone = zBtnNext);
1087 end;
1088
1089 if Horz then GR32.InflateRect(R, -BSize, 0) else GR32.InflateRect(R, 0, -BSize);
1090 if ShowEnabled then HandleRect := GetHandleRect
1091 else HandleRect := Rect(0, 0, 0, 0);
1092 ShowHandle := not GR32.IsRectEmpty(HandleRect);
1093
1094 DoDrawTrack(GetZoneRect(zTrackPrev), CPrevDirs[Horz], FDragZone = zTrackPrev, ShowEnabled, FHotZone = zTrackPrev);
1095 DoDrawTrack(GetZoneRect(zTrackNext), CNextDirs[Horz], FDragZone = zTrackNext, ShowEnabled, FHotZone = zTrackNext);
1096 if ShowHandle then DoDrawHandle(HandleRect, Horz, FDragZone = zHandle, FHotZone = zHandle);
1097end;
1098
1099procedure TArrowBar.SetBackgnd(Value: TRBBackgnd);
1100begin
1101 if Value <> FBackgnd then
1102 begin
1103 FBackgnd := Value;
1104 Invalidate;
1105 end;
1106end;
1107
1108procedure TArrowBar.SetBorderStyle(Value: TBorderStyle);
1109begin
1110 if Value <> FBorderStyle then
1111 begin
1112 FBorderStyle := Value;
1113{$IFNDEF FPC}
1114 RecreateWnd;
1115{$ELSE}
1116 Invalidate;
1117{$ENDIF}
1118 end;
1119end;
1120
1121procedure TArrowBar.SetButtonSize(Value: Integer);
1122begin
1123 if Value <> FButtonSize then
1124 begin
1125 FButtonSize := Value;
1126 Invalidate;
1127 end;
1128end;
1129
1130procedure TArrowBar.SetHandleColor(Value: TColor);
1131begin
1132 if Value <> FHandleColor then
1133 begin
1134 FHandleColor := Value;
1135 Invalidate;
1136 end;
1137end;
1138
1139procedure TArrowBar.SetHighLightColor(Value: TColor);
1140begin
1141 if Value <> FHighLightColor then
1142 begin
1143 FHighLightColor := Value;
1144 Invalidate;
1145 end;
1146end;
1147
1148procedure TArrowBar.SetButtonColor(Value: TColor);
1149begin
1150 if Value <> FButtonColor then
1151 begin
1152 FButtonColor := Value;
1153 Invalidate;
1154 end;
1155end;
1156
1157procedure TArrowBar.SetBorderColor(Value: TColor);
1158begin
1159 if Value <> FBorderColor then
1160 begin
1161 FBorderColor := Value;
1162 Invalidate;
1163 end;
1164end;
1165
1166procedure TArrowBar.SetShadowColor(Value: TColor);
1167begin
1168 if Value <> FShadowColor then
1169 begin
1170 FShadowColor := Value;
1171 Invalidate;
1172 end;
1173end;
1174
1175procedure TArrowBar.SetKind(Value: TScrollBarKind);
1176var
1177 Tmp: Integer;
1178begin
1179 if Value <> FKind then
1180 begin
1181 FKind := Value;
1182 if (csDesigning in ComponentState) and not (csLoading in ComponentState) then
1183 begin
1184 Tmp := Width;
1185 Width := Height;
1186 Height := Tmp;
1187 end;
1188 Invalidate;
1189 end;
1190end;
1191
1192procedure TArrowBar.SetShowArrows(Value: Boolean);
1193begin
1194 if Value <> FShowArrows then
1195 begin
1196 FShowArrows := Value;
1197 Invalidate;
1198 end;
1199end;
1200
1201procedure TArrowBar.SetShowHandleGrip(Value: Boolean);
1202begin
1203 if Value <> FShowHandleGrip then
1204 begin
1205 FShowHandleGrip := Value;
1206 Invalidate;
1207 end;
1208end;
1209
1210procedure TArrowBar.SetStyle(Value: TRBStyle);
1211begin
1212 FStyle := Value;
1213{$IFDEF FPC}
1214 Invalidate;
1215{$ELSE}
1216 RecreateWnd;
1217{$ENDIF}
1218end;
1219
1220procedure TArrowBar.StartDragTracking;
1221begin
1222 FTimer.Interval := FIRST_DELAY;
1223 FTimerMode := tmScroll;
1224 TimerHandler(Self);
1225 FTimerMode := tmScrollFirst;
1226 FTimer.Enabled := True;
1227end;
1228
1229procedure TArrowBar.StartHotTracking;
1230begin
1231 FTimer.Interval := HOTTRACK_INTERVAL;
1232 FTimerMode := tmHotTrack;
1233 FTimer.Enabled := True;
1234end;
1235
1236procedure TArrowBar.StopDragTracking;
1237begin
1238 StartHotTracking;
1239end;
1240
1241procedure TArrowBar.StopHotTracking;
1242begin
1243 FTimer.Enabled := False;
1244 FHotZone := zNone;
1245 Invalidate;
1246end;
1247
1248procedure TArrowBar.TimerHandler(Sender: TObject);
1249var
1250 Pt: TPoint;
1251begin
1252 case FTimerMode of
1253 tmScrollFirst:
1254 begin
1255 FTimer.Interval := SCROLL_INTERVAL;
1256 FTimerMode := tmScroll;
1257 end;
1258 tmHotTrack:
1259 begin
1260 Pt := ScreenToClient(Mouse.CursorPos);
1261 if not GR32.PtInRect(ClientRect, Pt) then
1262 begin
1263 StopHotTracking;
1264 Invalidate;
1265 end;
1266 end;
1267 end;
1268end;
1269
1270{$IFDEF FPC}
1271procedure TArrowBar.WMEraseBkgnd(var Message: TLmEraseBkgnd);
1272begin
1273 Message.Result := -1;
1274end;
1275
1276procedure TArrowBar.WMNCCalcSize(var Message: TLMNCCalcSize);
1277var
1278 Sz: Integer;
1279begin
1280 Sz := GetBorderSize;
1281 GR32.InflateRect(Message.CalcSize_Params.rgrc[0], -Sz, -Sz);
1282end;
1283
1284{$IFDEF Windows}
1285procedure TArrowBar.WMNCPaint(var Message: TWMNCPaint);
1286
1287 procedure DrawNCArea(ADC: HDC; const Clip: HRGN);
1288 var
1289 DC: HDC;
1290 R: TRect;
1291 begin
1292 if BorderStyle = bsNone then Exit;
1293 if ADC = 0 then DC := GetWindowDC(Handle)
1294 else DC := ADC;
1295 try
1296 GetWindowRect(Handle, R);
1297 OffsetRect(R, -R.Left, -R.Top);
1298 DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT);
1299 finally
1300 if ADC = 0 then ReleaseDC(Handle, DC);
1301 end;
1302 end;
1303
1304begin
1305 DrawNCArea(0, Message.RGN);
1306end;
1307{$ENDIF}
1308
1309{$ELSE}
1310
1311procedure TArrowBar.WMEraseBkgnd(var Message: TWmEraseBkgnd);
1312begin
1313 Message.Result := -1;
1314end;
1315
1316procedure TArrowBar.WMNCCalcSize(var Message: TWMNCCalcSize);
1317var
1318 Sz: Integer;
1319begin
1320 Sz := GetBorderSize;
1321 GR32.InflateRect(Message.CalcSize_Params.rgrc[0], -Sz, -Sz);
1322end;
1323
1324procedure TArrowBar.WMNCPaint(var Message: TWMNCPaint);
1325
1326 procedure DrawNCArea(ADC: HDC; const Clip: HRGN);
1327 var
1328 DC: HDC;
1329 R: TRect;
1330 begin
1331 if BorderStyle = bsNone then Exit;
1332 if ADC = 0 then DC := GetWindowDC(Handle)
1333 else DC := ADC;
1334 try
1335 GetWindowRect(Handle, R);
1336 GR32.OffsetRect(R, -R.Left, -R.Top);
1337 DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT);
1338 finally
1339 if ADC = 0 then ReleaseDC(Handle, DC);
1340 end;
1341 end;
1342
1343begin
1344 DrawNCArea(0, Message.RGN);
1345end;
1346{$ENDIF}
1347
1348{ TCustomRangeBar }
1349
1350procedure TCustomRangeBar.AdjustPosition;
1351begin
1352 if FPosition > Range - EffectiveWindow then FPosition := Range - EffectiveWindow;
1353 if FPosition < 0 then FPosition := 0;
1354end;
1355
1356constructor TCustomRangeBar.Create(AOwner: TComponent);
1357begin
1358 inherited;
1359 FIncrement := 8;
1360end;
1361
1362function TCustomRangeBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
1363 MousePos: TPoint): Boolean;
1364const OneHundredTwenteenth = 1 / 120;
1365begin
1366 Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
1367 if not Result then Position := Position + Increment * WheelDelta * OneHundredTwenteenth;
1368 Result := True;
1369end;
1370
1371function TCustomRangeBar.DrawEnabled: Boolean;
1372begin
1373 Result := Enabled and (Range > EffectiveWindow);
1374end;
1375
1376function TCustomRangeBar.GetHandleRect: TRect;
1377var
1378 BtnSz, ClientSz: Integer;
1379 HandleSz, HandlePos: Integer;
1380 R: TRect;
1381 Horz: Boolean;
1382begin
1383 R := Rect(0, 0, ClientWidth, ClientHeight);
1384 Horz := Kind = sbHorizontal;
1385 BtnSz := GetButtonSize;
1386 if Horz then
1387 begin
1388 GR32.InflateRect(R, -BtnSz, 0);
1389 ClientSz := R.Right - R.Left;
1390 end
1391 else
1392 begin
1393 GR32.InflateRect(R, 0, -BtnSz);
1394 ClientSz := R.Bottom - R.Top;
1395 end;
1396 if ClientSz < 18 then
1397 begin
1398 Result := Rect(0, 0, 0, 0);
1399 Exit;
1400 end;
1401
1402 if Range > EffectiveWindow then
1403 begin
1404 HandleSz := Round(ClientSz * EffectiveWindow / Range);
1405 if HandleSz >= MIN_SIZE then HandlePos := Round(ClientSz * Position / Range)
1406 else
1407 begin
1408 HandleSz := MIN_SIZE;
1409 HandlePos := Round((ClientSz - MIN_SIZE) * Position / (Range - EffectiveWindow));
1410 end;
1411 Result := R;
1412 if Horz then
1413 begin
1414 Result.Left := R.Left + HandlePos;
1415 Result.Right := R.Left + HandlePos + HandleSz;
1416 end
1417 else
1418 begin
1419 Result.Top := R.Top + HandlePos;
1420 Result.Bottom := R.Top + HandlePos + HandleSz;
1421 end;
1422 end
1423 else Result := R;
1424end;
1425
1426function TCustomRangeBar.IsPositionStored: Boolean;
1427begin
1428 Result := FPosition > 0;
1429end;
1430
1431procedure TCustomRangeBar.MouseDown(Button: TMouseButton;
1432 Shift: TShiftState; X, Y: Integer);
1433begin
1434 if Range <= EffectiveWindow then FDragZone := zNone
1435 else
1436 begin
1437 inherited;
1438 if FDragZone = zHandle then
1439 begin
1440 StopDragTracking;
1441 FPosBeforeDrag := Position;
1442 end;
1443 end;
1444end;
1445
1446procedure TCustomRangeBar.MouseMove(Shift: TShiftState; X, Y: Integer);
1447var
1448 Delta: Single;
1449 WinSz: Single;
1450 ClientSz, HandleSz: Integer;
1451begin
1452 inherited;
1453 if FDragZone = zHandle then
1454 begin
1455 WinSz := EffectiveWindow;
1456
1457 if Range <= WinSz then Exit;
1458 if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y;
1459
1460 if Kind = sbHorizontal then ClientSz := ClientWidth else ClientSz := ClientHeight;
1461 Dec(ClientSz, GetButtonSize * 2);
1462 if BorderStyle = bsSingle then Dec(ClientSz, 2);
1463 HandleSz := Round(ClientSz * WinSz / Range);
1464
1465 if HandleSz < MIN_SIZE then Delta := Round(Delta * (Range - WinSz) / (ClientSz - MIN_SIZE))
1466 else Delta := Delta * Range / ClientSz;
1467
1468 FGenChange := True;
1469 Position := FPosBeforeDrag + Delta;
1470 FGenChange := False;
1471 end;
1472end;
1473
1474procedure TCustomRangeBar.Resize;
1475var
1476 OldWindow: Integer;
1477 Center: Single;
1478begin
1479 if Centered then
1480 begin
1481 OldWindow := EffectiveWindow;
1482 UpdateEffectiveWindow;
1483 if Range > EffectiveWindow then
1484 begin
1485 if (Range > OldWindow) and (Range <> 0) then Center := (FPosition + OldWindow * 0.5) / Range
1486 else Center := 0.5;
1487 FPosition := Center * Range - EffectiveWindow * 0.5;
1488 end;
1489 end;
1490 AdjustPosition;
1491 inherited;
1492end;
1493
1494procedure TCustomRangeBar.SetParams(NewRange, NewWindow: Integer);
1495var
1496 OldWindow, OldRange: Integer;
1497 Center: Single;
1498begin
1499 if NewRange < 0 then NewRange := 0;
1500 if NewWindow < 0 then NewWindow := 0;
1501 if (NewRange <> FRange) or (NewWindow <> EffectiveWindow) then
1502 begin
1503 OldWindow := EffectiveWindow;
1504 OldRange := Range;
1505 FRange := NewRange;
1506 FWindow := NewWindow;
1507 UpdateEffectiveWindow;
1508 if Centered and (Range > EffectiveWindow) then
1509 begin
1510 if (OldRange > OldWindow) and (OldRange <> 0) then
1511 Center := (FPosition + OldWindow * 0.5) / OldRange
1512 else
1513 Center := 0.5;
1514 FPosition := Center * Range - EffectiveWindow * 0.5;
1515 end;
1516 AdjustPosition;
1517 Invalidate;
1518 end;
1519end;
1520
1521procedure TCustomRangeBar.SetPosition(Value: Single);
1522var
1523 OldPosition: Single;
1524begin
1525 if Value <> FPosition then
1526 begin
1527 OldPosition := FPosition;
1528 FPosition := Value;
1529 AdjustPosition;
1530 if OldPosition <> FPosition then
1531 begin
1532 Invalidate;
1533 DoChange;
1534 end;
1535 end;
1536end;
1537
1538procedure TCustomRangeBar.SetRange(Value: Integer);
1539begin
1540 SetParams(Value, Window);
1541end;
1542
1543procedure TCustomRangeBar.SetWindow(Value: Integer);
1544begin
1545 SetParams(Range, Value);
1546end;
1547
1548procedure TCustomRangeBar.TimerHandler(Sender: TObject);
1549var
1550 OldPosition: Single;
1551 Pt: TPoint;
1552
1553 function MousePos: TPoint;
1554 begin
1555 Result := ScreenToClient(Mouse.CursorPos);
1556 if Result.X < 0 then Result.X := 0;
1557 if Result.Y < 0 then Result.Y := 0;
1558 if Result.X >= ClientWidth then Result.X := ClientWidth - 1;
1559 if Result.Y >= ClientHeight then Result.Y := ClientHeight - 1
1560 end;
1561
1562begin
1563 inherited;
1564 FGenChange := True;
1565 OldPosition := Position;
1566
1567 case FDragZone of
1568 zBtnPrev:
1569 begin
1570 Position := Position - Increment;
1571 if Position = OldPosition then StopDragTracking;
1572 end;
1573
1574 zBtnNext:
1575 begin
1576 Position := Position + Increment;
1577 if Position = OldPosition then StopDragTracking;
1578 end;
1579
1580 zTrackNext:
1581 begin
1582 Pt := MousePos;
1583 if GetZone(Pt.X, Pt.Y) in [zTrackNext, zBtnNext] then
1584 Position := Position + EffectiveWindow;
1585 end;
1586
1587 zTrackPrev:
1588 begin
1589 Pt := MousePos;
1590 if GetZone(Pt.X, Pt.Y) in [zTrackPrev, zBtnPrev] then
1591 Position := Position - EffectiveWindow;
1592 end;
1593 end;
1594 FGenChange := False;
1595end;
1596
1597procedure TCustomRangeBar.UpdateEffectiveWindow;
1598begin
1599 if FWindow > 0 then FEffectiveWindow := FWindow
1600 else
1601 begin
1602 if Kind = sbHorizontal then FEffectiveWindow := Width
1603 else FEffectiveWindow := Height;
1604 end;
1605end;
1606
1607//----------------------------------------------------------------------------//
1608
1609{ TCustomGaugeBar }
1610
1611procedure TCustomGaugeBar.AdjustPosition;
1612begin
1613 if Position < Min then Position := Min
1614 else if Position > Max then Position := Max;
1615end;
1616
1617constructor TCustomGaugeBar.Create(AOwner: TComponent);
1618begin
1619 inherited;
1620 FLargeChange := 1;
1621 FMax := 100;
1622 FSmallChange := 1;
1623end;
1624
1625function TCustomGaugeBar.DoMouseWheel(Shift: TShiftState;
1626 WheelDelta: Integer; MousePos: TPoint): Boolean;
1627begin
1628 Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
1629 if not Result then Position := Position + FSmallChange * WheelDelta div 120;
1630 Result := True;
1631end;
1632
1633function TCustomGaugeBar.GetHandleRect: TRect;
1634var
1635 Sz, HandleSz: Integer;
1636 Horz: Boolean;
1637 Pos: Integer;
1638begin
1639 Result := GetTrackBoundary;
1640 Horz := Kind = sbHorizontal;
1641 HandleSz := GetHandleSize;
1642
1643 if Horz then Sz := Result.Right - Result.Left
1644 else Sz := Result.Bottom - Result.Top;
1645
1646 Pos := Round((Position - Min) / (Max - Min) * (Sz - GetHandleSize));
1647
1648 if Horz then
1649 begin
1650 Inc(Result.Left, Pos);
1651 Result.Right := Result.Left + HandleSz;
1652 end
1653 else
1654 begin
1655 Inc(Result.Top, Pos);
1656 Result.Bottom := Result.Top + HandleSz;
1657 end;
1658end;
1659
1660function TCustomGaugeBar.GetHandleSize: Integer;
1661var
1662 R: TRect;
1663 Sz: Integer;
1664begin
1665 Result := HandleSize;
1666 if Result = 0 then
1667 begin
1668 if Kind = sbHorizontal then Result := ClientHeight else Result := ClientWidth;
1669 end;
1670 R := GetTrackBoundary;
1671 if Kind = sbHorizontal then Sz := R.Right - R.Left
1672 else Sz := R.Bottom - R.Top;
1673 if Sz - Result < 1 then Result := Sz - 1;
1674 if Result < 0 then Result := 0;
1675end;
1676
1677procedure TCustomGaugeBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1678begin
1679 inherited;
1680 if FDragZone = zHandle then
1681 begin
1682 StopDragTracking;
1683 FPosBeforeDrag := Position;
1684 end;
1685end;
1686
1687procedure TCustomGaugeBar.MouseMove(Shift: TShiftState; X, Y: Integer);
1688var
1689 Delta: Single;
1690 R: TRect;
1691 ClientSz: Integer;
1692begin
1693 inherited;
1694 if FDragZone = zHandle then
1695 begin
1696 if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y;
1697 R := GetTrackBoundary;
1698
1699 if Kind = sbHorizontal then ClientSz := R.Right - R.Left
1700 else ClientSz := R.Bottom - R.Top;
1701
1702 Delta := Delta * (Max - Min) / (ClientSz - GetHandleSize);
1703
1704 FGenChange := True;
1705 Position := Round(FPosBeforeDrag + Delta);
1706 FGenChange := False;
1707 end;
1708end;
1709
1710procedure TCustomGaugeBar.SetHandleSize(Value: Integer);
1711begin
1712 if Value < 0 then Value := 0;
1713 if Value <> FHandleSize then
1714 begin
1715 FHandleSize := Value;
1716 Invalidate;
1717 end;
1718end;
1719
1720procedure TCustomGaugeBar.SetLargeChange(Value: Integer);
1721begin
1722 if Value < 1 then Value := 1;
1723 FLargeChange := Value;
1724end;
1725
1726procedure TCustomGaugeBar.SetMax(Value: Integer);
1727begin
1728 if (Value <= FMin) and not (csLoading in ComponentState) then Value := FMin + 1;
1729 if Value <> FMax then
1730 begin
1731 FMax := Value;
1732 AdjustPosition;
1733 Invalidate;
1734 end;
1735end;
1736
1737procedure TCustomGaugeBar.SetMin(Value: Integer);
1738begin
1739 if (Value >= FMax) and not (csLoading in ComponentState) then Value := FMax - 1;
1740 if Value <> FMin then
1741 begin
1742 FMin := Value;
1743 AdjustPosition;
1744 Invalidate;
1745 end;
1746end;
1747
1748procedure TCustomGaugeBar.SetPosition(Value: Integer);
1749begin
1750 if Value < Min then Value := Min
1751 else if Value > Max then Value := Max;
1752 if Round(FPosition) <> Value then
1753 begin
1754 FPosition := Value;
1755 Invalidate;
1756 DoChange;
1757 end;
1758end;
1759
1760procedure TCustomGaugeBar.SetSmallChange(Value: Integer);
1761begin
1762 if Value < 1 then Value := 1;
1763 FSmallChange := Value;
1764end;
1765
1766procedure TCustomGaugeBar.TimerHandler(Sender: TObject);
1767var
1768 OldPosition: Single;
1769 Pt: TPoint;
1770
1771 function MousePos: TPoint;
1772 begin
1773 Result := ScreenToClient(Mouse.CursorPos);
1774 if Result.X < 0 then Result.X := 0;
1775 if Result.Y < 0 then Result.Y := 0;
1776 if Result.X >= ClientWidth then Result.X := ClientWidth - 1;
1777 if Result.Y >= ClientHeight then Result.Y := ClientHeight - 1
1778 end;
1779
1780begin
1781 inherited;
1782 FGenChange := True;
1783 OldPosition := Position;
1784
1785 case FDragZone of
1786 zBtnPrev:
1787 begin
1788 Position := Position - SmallChange;
1789 if Position = OldPosition then StopDragTracking;
1790 end;
1791
1792 zBtnNext:
1793 begin
1794 Position := Position + SmallChange;
1795 if Position = OldPosition then StopDragTracking;
1796 end;
1797
1798 zTrackNext:
1799 begin
1800 Pt := MousePos;
1801 if GetZone(Pt.X, Pt.Y) in [zTrackNext, zBtnNext] then
1802 Position := Position + LargeChange;
1803 end;
1804
1805 zTrackPrev:
1806 begin
1807 Pt := MousePos;
1808 if GetZone(Pt.X, Pt.Y) in [zTrackPrev, zBtnPrev] then
1809 Position := Position - LargeChange;
1810 end;
1811 end;
1812 FGenChange := False;
1813end;
1814
1815{ TArrowBarAccess }
1816
1817function TArrowBarAccess.GetBackgnd: TRBBackgnd;
1818begin
1819 Result := FMaster.Backgnd;
1820end;
1821
1822function TArrowBarAccess.GetButtonSize: Integer;
1823begin
1824 Result := FMaster.ButtonSize;
1825end;
1826
1827function TArrowBarAccess.GetColor: TColor;
1828begin
1829 Result := FMaster.Color;
1830end;
1831
1832function TArrowBarAccess.GetHandleColor: TColor;
1833begin
1834 Result := FMaster.HandleColor;
1835end;
1836
1837function TArrowBarAccess.GetHighLightColor: TColor;
1838begin
1839 Result := FMaster.HighLightColor;
1840end;
1841
1842function TArrowBarAccess.GetShadowColor: TColor;
1843begin
1844 Result := FMaster.ShadowColor;
1845end;
1846
1847function TArrowBarAccess.GetButtonColor: TColor;
1848begin
1849 Result := FMaster.ButtonColor;
1850end;
1851
1852function TArrowBarAccess.GetBorderColor: TColor;
1853begin
1854 Result := FMaster.BorderColor;
1855end;
1856
1857function TArrowBarAccess.GetShowArrows: Boolean;
1858begin
1859 Result := FMaster.ShowArrows;
1860end;
1861
1862function TArrowBarAccess.GetShowHandleGrip: Boolean;
1863begin
1864 Result := FMaster.ShowHandleGrip;
1865end;
1866
1867function TArrowBarAccess.GetStyle: TRBStyle;
1868begin
1869 Result := FMaster.Style;
1870end;
1871
1872procedure TArrowBarAccess.SetBackgnd(Value: TRBBackgnd);
1873begin
1874 FMaster.Backgnd := Value;
1875 if FSlave <> nil then FSlave.Backgnd := Value;
1876end;
1877
1878procedure TArrowBarAccess.SetButtonSize(Value: Integer);
1879begin
1880 FMaster.ButtonSize := Value;
1881 if FSlave <> nil then FSlave.ButtonSize := Value;
1882end;
1883
1884procedure TArrowBarAccess.SetColor(Value: TColor);
1885begin
1886 FMaster.Color := Value;
1887 if FSlave <> nil then FSlave.Color := Value;
1888end;
1889
1890procedure TArrowBarAccess.SetHandleColor(Value: TColor);
1891begin
1892 FMaster.HandleColor := Value;
1893 if FSlave <> nil then FSlave.HandleColor := Value;
1894end;
1895
1896procedure TArrowBarAccess.SetHighLightColor(Value: TColor);
1897begin
1898 FMaster.HighLightColor := Value;
1899 if FSlave <> nil then FSlave.HighLightColor := Value;
1900end;
1901
1902procedure TArrowBarAccess.SetShadowColor(Value: TColor);
1903begin
1904 FMaster.ShadowColor := Value;
1905 if FSlave <> nil then FSlave.ShadowColor := Value;
1906end;
1907
1908procedure TArrowBarAccess.SetButtonColor(Value: TColor);
1909begin
1910 FMaster.ButtonColor := Value;
1911 if FSlave <> nil then FSlave.ButtonColor := Value;
1912end;
1913
1914procedure TArrowBarAccess.SetBorderColor(Value: TColor);
1915begin
1916 FMaster.BorderColor := Value;
1917 if FSlave <> nil then FSlave.BorderColor := Value;
1918end;
1919
1920procedure TArrowBarAccess.SetShowArrows(Value: Boolean);
1921begin
1922 FMaster.ShowArrows := Value;
1923 if FSlave <> nil then FSlave.ShowArrows := Value;
1924end;
1925
1926procedure TArrowBarAccess.SetShowHandleGrip(Value: Boolean);
1927begin
1928 FMaster.ShowHandleGrip := Value;
1929 if FSlave <> nil then FSlave.ShowHandleGrip := Value;
1930end;
1931
1932procedure TArrowBarAccess.SetStyle(Value: TRBStyle);
1933begin
1934 FMaster.Style := Value;
1935 if FSlave <> nil then FSlave.Style := Value;
1936end;
1937
1938end.
Note: See TracBrowser for help on using the repository browser.