unit GR32_RangeBars; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf * Marc Lafon * * ***** END LICENSE BLOCK ***** *) interface {$include GR32.inc} uses {$IFDEF FPC} LCLIntf, LMessages, LCLType, Graphics, Controls, Forms, Dialogs, ExtCtrls, {$ifdef MSWINDOWS} Windows, {$ENDIF} {$ELSE} Windows, Messages, {$IFDEF USEINLINING}Types,{$ENDIF} Graphics, Controls, Forms, Dialogs, ExtCtrls, {$ENDIF} {$ifdef MSWINDOWS} UxTheme, {$endif} SysUtils, Classes, GR32; type TRBDirection = (drLeft, drUp, drRight, drDown); TRBDirections = set of TRBDirection; TRBZone = (zNone, zBtnPrev, zTrackPrev, zHandle, zTrackNext, zBtnNext); TRBStyle = (rbsDefault, rbsMac); TRBBackgnd = (bgPattern, bgSolid); TRBGetSizeEvent = procedure(Sender: TObject; var Size: Integer) of object; TArrowBar = class(TCustomControl) private FBackgnd: TRBBackgnd; FBorderStyle: TBorderStyle; FButtonSize: Integer; FHandleColor: TColor; FButtoncolor:TColor; FHighLightColor:TColor; FShadowColor:TColor; FBorderColor:TColor; FKind: TScrollBarKind; FShowArrows: Boolean; FShowHandleGrip: Boolean; FStyle: TRBStyle; FOnChange: TNotifyEvent; FOnUserChange: TNotifyEvent; FLockUpdate: integer; procedure SetButtonSize(Value: Integer); procedure SetHandleColor(Value: TColor); procedure SetHighLightColor(Value: TColor); procedure SetShadowColor(Value: TColor); procedure SetButtonColor(Value: TColor); procedure SetBorderColor(Value: TColor); procedure SetKind(Value: TScrollBarKind); procedure SetShowArrows(Value: Boolean); procedure SetShowHandleGrip(Value: Boolean); procedure SetStyle(Value: TRBStyle); procedure SetBackgnd(Value: TRBBackgnd); {$IFDEF FPC} procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED; procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure WMNCCalcSize(var Message: TLMNCCalcSize); message LM_NCCALCSIZE; procedure WMEraseBkgnd(var Message: TLmEraseBkgnd); message LM_ERASEBKGND; {$ifdef MSWINDOWS} procedure WMNCPaint(var Message: TWMNCPaint); message LM_NCPAINT; {$ENDIF} {$ELSE} procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT; procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; {$ENDIF} protected FGenChange: Boolean; FDragZone: TRBZone; FHotZone: TRBZone; FTimer: TTimer; FTimerMode: Integer; FStored: TPoint; FPosBeforeDrag: Single; {$ifdef MSWINDOWS} protected FScrollBarTheme: HTHEME; function GetScrollBarTheme: HTHEME; property ScrollBarTheme: HTHEME read GetScrollBarTheme; {$endif} protected procedure BeginLockUpdate; procedure EndLockUpdate; property LockUpdate: integer read FLockUpdate; procedure DoChange; virtual; procedure DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual; procedure DoDrawHandle(R: TRect; Horz: Boolean; Pushed, Hot: Boolean); virtual; procedure DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual; function DrawEnabled: Boolean; virtual; function GetBorderSize: Integer; function GetHandleRect: TRect; virtual; function GetButtonSize: Integer; function GetTrackBoundary: TRect; function GetZone(X, Y: Integer): TRBZone; function GetZoneRect(Zone: TRBZone): TRect; procedure MouseLeft; virtual; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Paint; override; procedure SetBorderStyle(Value: TBorderStyle); {$IFDEF FPC} override; {$ENDIF} procedure StartDragTracking; procedure StartHotTracking; procedure StopDragTracking; procedure StopHotTracking; procedure TimerHandler(Sender: TObject); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Color default clScrollBar; property Backgnd: TRBBackgnd read FBackgnd write SetBackgnd; property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property ButtonSize: Integer read FButtonSize write SetButtonSize default 0; property HandleColor: TColor read FHandleColor write SetHandleColor default clBtnShadow; property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace; property HighLightColor: TColor read FHighLightColor write SetHighLightColor default clBtnHighlight; property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow; property BorderColor: TColor read FBorderColor write SetBorderColor default clWindowFrame; property Kind: TScrollBarKind read FKind write SetKind default sbHorizontal; property ShowArrows: Boolean read FShowArrows write SetShowArrows default True; property ShowHandleGrip: Boolean read FShowHandleGrip write SetShowHandleGrip; property Style: TRBStyle read FStyle write SetStyle default rbsDefault; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange; end; TRBIncrement = 1..32768; TRangeBarChangingEvent = procedure(Sender: TObject; ANewPosition: Single; var Handled: boolean) of object; TCustomRangeBar = class(TArrowBar) private FCentered: Boolean; FEffectiveWindow: Integer; FIncrement: TRBIncrement; FPosition: Single; FRange: Integer; FWindow: Integer; FOnUserChanging: TRangeBarChangingEvent; function IsPositionStored: Boolean; procedure SetPosition(Value: Single); procedure SetRange(Value: Integer); procedure SetWindow(Value: Integer); protected procedure DoChanging(ANewPosition: Single; var Handled: boolean); virtual; procedure AdjustPosition; overload; procedure AdjustPosition(var APosition: Single); overload; function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; function DrawEnabled: Boolean; override; function GetHandleRect: TRect; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure TimerHandler(Sender: TObject); override; procedure UpdateEffectiveWindow; property EffectiveWindow: Integer read FEffectiveWindow; public constructor Create(AOwner: TComponent); override; procedure Resize; override; procedure SetParams(NewRange, NewWindow: Integer); property Centered: Boolean read FCentered write FCentered; property Increment: TRBIncrement read FIncrement write FIncrement default 8; property Position: Single read FPosition write SetPosition stored IsPositionStored; property Range: Integer read FRange write SetRange default 0; property Window: Integer read FWindow write SetWindow default 0; property OnUserChanging: TRangeBarChangingEvent read FOnUserChanging write FOnUserChanging; end; TRangeBar = class(TCustomRangeBar) published property Align; property Anchors; property Constraints; property Color; property Backgnd; property BorderStyle; property ButtonSize; property Enabled; property HandleColor; property ButtonColor; property HighLightColor; property ShadowColor; property BorderColor; property Increment; property Kind; property Range; property Style; property Visible; property Window; property ShowArrows; property ShowHandleGrip; property Position; // this should be located after the Range property property OnChange; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheelUp; property OnMouseWheelDown; property OnStartDrag; property OnUserChange; property OnUserChanging; end; TGaugeBarChangingEvent = procedure(Sender: TObject; ANewPosition: integer; var Handled: boolean) of object; TCustomGaugeBar = class(TArrowBar) private FHandleSize: Integer; FLargeChange: Integer; FMax: Integer; FMin: Integer; FPosition: Integer; FSmallChange: Integer; FOnUserChanging: TGaugeBarChangingEvent; procedure SetHandleSize(Value: Integer); procedure SetMax(Value: Integer); procedure SetMin(Value: Integer); procedure SetPosition(Value: Integer); procedure SetLargeChange(Value: Integer); procedure SetSmallChange(Value: Integer); protected procedure DoChanging(ANewPosition: integer; var Handled: boolean); virtual; procedure AdjustPosition; overload; procedure AdjustPosition(var APosition: integer); overload; function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; function GetHandleRect: TRect; override; function GetHandleSize: Integer; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure TimerHandler(Sender: TObject); override; public constructor Create(AOwner: TComponent); override; property HandleSize: Integer read FHandleSize write SetHandleSize default 0; property LargeChange: Integer read FLargeChange write SetLargeChange default 1; property Max: Integer read FMax write SetMax default 100; property Min: Integer read FMin write SetMin default 0; property Position: Integer read FPosition write SetPosition; property SmallChange: Integer read FSmallChange write SetSmallChange default 1; property OnChange; property OnUserChange; property OnUserChanging: TGaugeBarChangingEvent read FOnUserChanging write FOnUserChanging; end; TGaugeBar = class(TCustomGaugeBar) published property Align; property Anchors; property Constraints; property Color; property Backgnd; property BorderStyle; property ButtonSize; property Enabled; property HandleColor; property ButtonColor; property HighLightColor; property ShadowColor; property BorderColor; property HandleSize; property Kind; property LargeChange; property Max; property Min; property ShowArrows; property ShowHandleGrip; property Style; property SmallChange; property Visible; property Position; property OnChange; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; property OnUserChange; end; { TArrowBarAccess } { This class is designed to facilitate access to properties of TArrowBar class when creating custom controls, which incorporate TArrowBar. It allows controlling up to two arrow bars. Master is used to read and write properties, slave - only to write. Well, maybe it is not so useful itself, but it is a common ancestor for TRangeBarAccess and TGaugeBarAccess classes, which work much the same way. When writing a new control, which uses TArrowBar, declare the bar as protected member, TArrowBarAccess as published property, and assign its Master to the arrow bar } TArrowBarAccess = class(TPersistent) private FMaster: TArrowBar; FSlave: TArrowBar; function GetBackgnd: TRBBackgnd; function GetButtonSize: Integer; function GetColor: TColor; function GetHandleColor: TColor; function GetHighLightColor: TColor; function GetButtonColor: TColor; function GetBorderColor: TColor; function GetShadowColor: TColor; function GetShowArrows: Boolean; function GetShowHandleGrip: Boolean; function GetStyle: TRBStyle; procedure SetBackgnd(Value: TRBBackgnd); procedure SetButtonSize(Value: Integer); procedure SetColor(Value: TColor); procedure SetHandleColor(Value: TColor); procedure SetShowArrows(Value: Boolean); procedure SetShowHandleGrip(Value: Boolean); procedure SetStyle(Value: TRBStyle); procedure SetHighLightColor(Value: TColor); procedure SetShadowColor(Value: TColor); procedure SetButtonColor(Value: TColor); procedure SetBorderColor(Value: TColor); public property Master: TArrowBar read FMaster write FMaster; property Slave: TArrowBar read FSlave write FSlave; published property Color: TColor read GetColor write SetColor default clScrollBar; property Backgnd: TRBBackgnd read GetBackgnd write SetBackgnd default bgPattern; property ButtonSize: Integer read GetButtonSize write SetButtonSize default 0; property HandleColor: TColor read GetHandleColor write SetHandleColor default clBtnShadow; property ButtonColor:TColor read GetButtonColor write SetButtonColor default clBtnFace; property HighLightColor:TColor read GetHighLightColor write SetHighLightColor default clBtnHighlight; property ShadowColor:TColor read GetShadowColor write SetShadowColor default clBtnShadow; property BorderColor:TColor read GetBorderColor write SetBorderColor default clWindowFrame; property ShowArrows: Boolean read GetShowArrows write SetShowArrows default True; property ShowHandleGrip: Boolean read GetShowHandleGrip write SetShowHandleGrip; property Style: TRBStyle read GetStyle write SetStyle; end; implementation uses Math; const OppositeDirection: array [TRBDirection] of TRBDirection = (drRight, drDown, drLeft, drUp); tmScrollFirst = 1; tmScroll = 2; tmHotTrack = 3; function ClrLighten(C: TColor; Amount: Integer): TColor; var R, G, B: Integer; begin {$ifdef MSWINDOWS} if C < 0 then C := GetSysColor(C and $000000FF); {$ELSE} C := ColorToRGB(C); {$ENDIF} R := C and $FF + Amount; G := C shr 8 and $FF + Amount; B := C shr 16 and $FF + Amount; if R < 0 then R := 0 else if R > 255 then R := 255; if G < 0 then G := 0 else if G > 255 then G := 255; if B < 0 then B := 0 else if B > 255 then B := 255; Result := R or (G shl 8) or (B shl 16); end; function MixColors(C1, C2: TColor; W1: Integer): TColor; var W2: Cardinal; begin Assert(W1 in [0..255]); W2 := W1 xor 255; {$ifdef MSWINDOWS} if Integer(C1) < 0 then C1 := GetSysColor(C1 and $000000FF); if Integer(C2) < 0 then C2 := GetSysColor(C2 and $000000FF); {$ELSE} C1 := ColorToRGB(C1); C2 := ColorToRGB(C2); {$ENDIF} Result := Integer( ((Cardinal(C1) and $FF00FF) * Cardinal(W1) + (Cardinal(C2) and $FF00FF) * W2) and $FF00FF00 + ((Cardinal(C1) and $00FF00) * Cardinal(W1) + (Cardinal(C2) and $00FF00) * W2) and $00FF0000) shr 8; end; procedure DitherRect(Canvas: TCanvas; const R: TRect; C1, C2: TColor); var {$IFDEF FPC} Brush: TBrush; OldBrush: TBrush; {$ELSE} B: TBitmap; Brush: HBRUSH; {$ENDIF} begin if GR32.IsRectEmpty(R) then Exit; {$IFDEF FPC} Brush := TBrush.Create; try Brush.Color := ColorToRGB(C1); if C1 <> C2 then begin Brush.Bitmap := Graphics.TBitmap.Create; with Brush.Bitmap do begin Height := 2; Width := 2; Canvas.Pixels[0,0] := C1; Canvas.Pixels[1,0] := C2; Canvas.Pixels[0,1] := C2; Canvas.Pixels[1,1] := C1; end; Brush.Color := ColorToRGB(C1); end; OldBrush := TBrush.Create; try OldBrush.Assign(Canvas.Brush); Canvas.Brush.Assign(Brush); Canvas.FillRect(R); Canvas.Brush.Assign(OldBrush); finally OldBrush.Free; end; finally if Assigned(Brush.Bitmap) then Brush.Bitmap.Free; Brush.Free; end; {$ELSE} if C1 = C2 then Brush := CreateSolidBrush(ColorToRGB(C1)) else begin B := AllocPatternBitmap(C1, C2); B.HandleType := bmDDB; Brush := CreatePatternBrush(B.Handle); end; FillRect(Canvas.Handle, R, Brush); DeleteObject(Brush); {$ENDIF} end; procedure DrawRectEx(Canvas: TCanvas; var R: TRect; Sides: TRBDirections; C: TColor); begin if Sides <> [] then with Canvas, R do begin Pen.Color := C; if drUp in Sides then begin MoveTo(Left, Top); LineTo(Right, Top); Inc(Top); end; if drDown in Sides then begin Dec(Bottom); MoveTo(Left, Bottom); LineTo(Right, Bottom); end; if drLeft in Sides then begin MoveTo(Left, Top); LineTo(Left, Bottom); Inc(Left); end; if drRight in Sides then begin Dec(Right); MoveTo(Right, Top); LineTo(Right, Bottom); end; end; end; procedure Frame3D(Canvas: TCanvas; var ARect: TRect; TopColor, BottomColor: TColor; AdjustRect: Boolean = True); var TopRight, BottomLeft: TPoint; begin with Canvas, ARect do begin Pen.Width := 1; Dec(Bottom); Dec(Right); TopRight.X := Right; TopRight.Y := Top; BottomLeft.X := Left; BottomLeft.Y := Bottom; Pen.Color := TopColor; PolyLine([BottomLeft, TopLeft, TopRight]); Pen.Color := BottomColor; Dec(Left); PolyLine([TopRight, BottomRight, BottomLeft]); if AdjustRect then begin Inc(Top); Inc(Left, 2); end else begin Inc(Left); Inc(Bottom); Inc(Right); end; end; end; procedure DrawHandle(Canvas: TCanvas; R: TRect; Color: TColor; Pushed, ShowGrip, IsHorz: Boolean; ColorBorder: TColor); var CHi, CLo: TColor; I, S: Integer; begin CHi := ClrLighten(Color, 24); CLo := ClrLighten(Color, -24); Canvas.Brush.Color := ColorBorder; FrameRect(Canvas.Handle, R, Canvas.Brush.Handle); GR32.InflateRect(R, -1, -1); if Pushed then Frame3D(Canvas, R, CLo, Color) else Frame3D(Canvas, R, CHi, MixColors(ColorBorder, Color, 96)); Canvas.Brush.Color := Color; Canvas.FillRect(R); if ShowGrip then begin if Pushed then GR32.OffsetRect(R, 1, 1); if IsHorz then begin S := R.Right - R.Left; R.Left := (R.Left + R.Right) div 2 - 5; R.Right := R.Left + 2; Inc(R.Top); Dec(R.Bottom); if S > 10 then Frame3D(Canvas, R, CHi, CLo, False); Inc(R.Left, 3); Inc(R.Right, 3); Frame3D(Canvas, R, CHi, CLo, False); Inc(R.Left, 3); Inc(R.Right, 3); Frame3D(Canvas, R, CHi, CLo, False); Inc(R.Left, 3); Inc(R.Right, 3); if S > 10 then Frame3D(Canvas, R, CHi, CLo, False); end else begin I := (R.Top + R.Bottom) div 2; S := R.Bottom - R.Top; R.Top := I - 1; R.Bottom := I + 1; Dec(R.Right); Inc(R.Left); GR32.OffsetRect(R, 0, -4); if S > 10 then Frame3D(Canvas, R, CHi, CLo, False); GR32.OffsetRect(R, 0, 3); Frame3D(Canvas, R, CHi, CLo, False); GR32.OffsetRect(R, 0, 3); Frame3D(Canvas, R, CHi, CLo, False); if S > 10 then begin GR32.OffsetRect(R, 0, 3); Frame3D(Canvas, R, CHi, CLo, False); end; end; end; end; procedure DrawArrow(Canvas: TCanvas; R: TRect; Direction: TRBDirection; Color: TColor); var X, Y, Sz, Shift: Integer; begin X := (R.Left + R.Right - 1) div 2; Y := (R.Top + R.Bottom - 1) div 2; Sz := (Min(X - R.Left, Y - R.Top)) * 3 div 4 - 1; if Sz = 0 then Sz := 1; if Direction in [drUp, drLeft] then Shift := (Sz + 1) * 1 div 3 else Shift := Sz * 1 div 3; Canvas.Pen.Color := Color; Canvas.Brush.Color := Color; case Direction of drUp: begin Inc(Y, Shift); Canvas.Polygon([Point(X + Sz, Y), Point(X, Y - Sz), Point(X - Sz, Y)]); end; drDown: begin Dec(Y, Shift); Canvas.Polygon([Point(X + Sz, Y), Point(X, Y + Sz), Point(X - Sz, Y)]); end; drLeft: begin Inc(X, Shift); Canvas.Polygon([Point(X, Y + Sz), Point(X - Sz, Y), Point(X, Y - Sz)]); end; drRight: begin Dec(X, Shift); Canvas.Polygon([Point(X, Y + Sz), Point(X + Sz, Y), Point(X, Y - Sz)]); end; end; end; const FIRST_DELAY = 600; SCROLL_INTERVAL = 100; HOTTRACK_INTERVAL = 150; MIN_SIZE = 17; { TArrowBar } {$IFDEF FPC} procedure TArrowBar.CMEnabledChanged(var Message: TLMessage); {$ELSE} procedure TArrowBar.CMEnabledChanged(var Message: TMessage); {$ENDIF} begin inherited; Invalidate; end; {$IFDEF FPC} procedure TArrowBar.CMMouseLeave(var Message: TLMessage); {$ELSE} procedure TArrowBar.CMMouseLeave(var Message: TMessage); {$ENDIF} begin MouseLeft; inherited; end; constructor TArrowBar.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle - [csAcceptsControls, csDoubleClicks] + [csOpaque]; Width := 100; Height := 16; ParentColor := False; Color := clScrollBar; FTimer := TTimer.Create(Self); FTimer.OnTimer := TimerHandler; FShowArrows := True; FBorderStyle := bsSingle; FHandleColor := clBtnShadow; FButtonColor := clBtnFace; FHighLightColor := clBtnHighlight; FShadowColor := clBtnShadow; FBorderColor := clWindowFrame; FShowHandleGrip := True; end; destructor TArrowBar.Destroy; begin {$ifdef MSWINDOWS} if (FScrollBarTheme <> 0) then CloseThemeData(FScrollBarTheme); {$endif} inherited; end; procedure TArrowBar.BeginLockUpdate; begin Inc(FLockUpdate); end; procedure TArrowBar.EndLockUpdate; begin Dec(FLockUpdate); end; procedure TArrowBar.DoChange; begin if (LockUpdate > 0) then Exit; BeginLockUpdate; try if Assigned(FOnChange) then FOnChange(Self); if FGenChange and Assigned(FOnUserChange) then FOnUserChange(Self); finally EndLockUpdate; end; end; procedure TArrowBar.DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); const EnabledFlags: array [Boolean] of Integer = (DFCS_INACTIVE, 0); PushedFlags: array [Boolean] of Integer = (0, DFCS_PUSHED or DFCS_FLAT); DirectionFlags: array [TRBDirection] of Integer = (DFCS_SCROLLLEFT, DFCS_SCROLLUP, DFCS_SCROLLRIGHT, DFCS_SCROLLDOWN); {$ifdef MSWINDOWS} DirectionXPFlags: array [TRBDirection] of Cardinal = (ABS_LEFTNORMAL, ABS_UPNORMAL, ABS_RIGHTNORMAL, ABS_DOWNNORMAL); {$ENDIF} var Edges: TRBDirections; {$ifdef MSWINDOWS} Flags: Integer; {$ENDIF} begin if Style = rbsDefault then begin {$IFDEF FPC} {$IFNDEF Windows} Canvas.Brush.Color := clBtnface; Canvas.FillRect(R); LCLIntf.DrawFrameControl(Canvas.Handle, R, DFC_BUTTON, 0); InflateRect(R, -2, -2); If not DrawEnabled then begin InflateRect(R, -1, -1); OffsetRect(R, 1, 1); DrawArrow(Canvas, R, Direction, clWhite); OffsetRect(R, -1, -1); DrawArrow(Canvas, R, Direction, clGrayText); end else begin If Pushed then OffsetRect(R, 1, 1); DrawArrow(Canvas, R, Direction, clBtnText); end; {$ENDIF} {$ENDIF} {$ifdef MSWINDOWS} if UseThemes then begin Flags := DirectionXPFlags[Direction]; if not Enabled then Inc(Flags, 3) else if Pushed then Inc(Flags, 2) else if Hot then Inc(Flags); DrawThemeBackground(ScrollBarTheme, Canvas.Handle, SBP_ARROWBTN, Flags, R, nil); end else DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, DirectionFlags[Direction] or EnabledFlags[DrawEnabled] or PushedFlags[Pushed]) {$ENDIF} end else begin Edges := [drLeft, drUp, drRight, drDown]; Exclude(Edges, OppositeDirection[Direction]); if not DrawEnabled then begin DrawRectEx(Canvas, R, Edges, fShadowColor); Canvas.Brush.Color := fButtonColor; FillRect(Canvas.Handle, R, Canvas.Brush.Handle); GR32.InflateRect(R, -1, -1); GR32.OffsetRect(R, 1, 1); DrawArrow(Canvas, R, Direction, fHighLightColor); GR32.OffsetRect(R, -1, -1); DrawArrow(Canvas, R, Direction, fShadowColor); end else begin DrawRectEx(Canvas, R, Edges, fBorderColor); if Pushed then begin Canvas.Brush.Color := fButtonColor; FillRect(Canvas.Handle, R, Canvas.Brush.Handle); GR32.OffsetRect(R, 1, 1); GR32.InflateRect(R, -1, -1); end else begin Frame3D(Canvas, R, fHighLightColor, fShadowColor, True); Canvas.Brush.Color := fButtonColor; FillRect(Canvas.Handle, R, Canvas.Brush.Handle); end; DrawArrow(Canvas, R, Direction, fBorderColor); end; end; end; procedure TArrowBar.DoDrawHandle(R: TRect; Horz, Pushed, Hot: Boolean); {$ifdef MSWINDOWS} const PartXPFlags: array [Boolean] of Cardinal = (SBP_THUMBBTNVERT, SBP_THUMBBTNHORZ); GripperFlags: array [Boolean] of Cardinal = (SBP_GRIPPERVERT, SBP_GRIPPERHORZ); var Flags: Cardinal; {$ENDIF} begin if GR32.IsRectEmpty(R) then Exit; case Style of rbsDefault: begin {$ifdef MSWINDOWS} if UseThemes then begin Flags := SCRBS_NORMAL; if not Enabled then Inc(Flags, 3) else if Pushed then Inc(Flags, 2) else if Hot then Inc(Flags); DrawThemeBackground(ScrollBarTheme, Canvas.Handle, PartXPFlags[Horz], Flags, R, nil); if ShowHandleGrip then DrawThemeBackground(ScrollBarTheme, Canvas.Handle, GripperFlags[Horz], 0, R, nil); end else DrawEdge(Canvas.Handle, R, EDGE_RAISED, BF_RECT or BF_MIDDLE); {$ENDIF} end; rbsMac: begin DrawHandle(Canvas, R, HandleColor, Pushed, ShowHandleGrip, Horz, fBorderColor); end; end; end; procedure TArrowBar.DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); {$ifdef MSWINDOWS} const PartXPFlags: array [TRBDirection] of Cardinal = (SBP_LOWERTRACKHORZ, SBP_LOWERTRACKVERT, SBP_UPPERTRACKHORZ, SBP_UPPERTRACKVERT); {$ENDIF} var {$ifdef MSWINDOWS} Flags: Cardinal; {$ENDIF} C: TColor; Edges: set of TRBDirection; begin if (R.Right <= R.Left) or (R.Bottom <= R.Top) then Exit; if Style = rbsDefault then begin {$ifdef MSWINDOWS} if UseThemes then begin Flags := SCRBS_NORMAL; if Pushed then Inc(Flags, 2); DrawThemeBackground(ScrollBarTheme, Canvas.Handle, PartXPFlags[Direction], Flags, R, nil); end else {$ENDIF} begin if Pushed then DitherRect(Canvas, R, clWindowFrame, clWindowFrame) else DitherRect(Canvas, R, clBtnHighlight, Color); end; end else with Canvas, R do begin if DrawEnabled then C := FBorderColor else C := FShadowColor; Edges := [drLeft, drUp, drRight, drDown]; Exclude(Edges, OppositeDirection[Direction]); DrawRectEx(Canvas, R, Edges, C); if Pushed then DitherRect(Canvas, R, fBorderColor,fBorderColor) else if not GR32.IsRectEmpty(R) then with R do begin if DrawEnabled then begin Pen.Color := MixColors(fBorderColor, MixColors(fHighLightColor, Color, 127), 32); case Direction of drLeft, drUp: begin MoveTo(Left, Bottom - 1); LineTo(Left, Top); LineTo(Right, Top); Inc(Top); Inc(Left); end; drRight: begin MoveTo(Left, Top); LineTo(Right, Top); Inc(Top); end; drDown: begin MoveTo(Left, Top); LineTo(Left, Bottom); Inc(Left); end; end; if Backgnd = bgPattern then DitherRect(Canvas, R, fHighLightColor, Color) else DitherRect(Canvas, R, Color, Color); end else begin Brush.Color := fButtonColor; FillRect(R); end; end; end; end; function TArrowBar.DrawEnabled: Boolean; begin Result := Enabled; end; function TArrowBar.GetBorderSize: Integer; const CSize: array [Boolean] of Integer = (0, 1); begin Result := CSize[BorderStyle = bsSingle]; end; function TArrowBar.GetButtonSize: Integer; var W, H: Integer; begin if not ShowArrows then Result := 0 else begin Result := ButtonSize; if Kind = sbHorizontal then begin W := ClientWidth; H := ClientHeight; end else begin W := ClientHeight; H := ClientWidth; end; if Result = 0 then Result := Min(H, 32); if Result * 2 >= W then Result := W div 2; if Style = rbsMac then Dec(Result); if Result < 2 then Result := 0; end; end; function TArrowBar.GetHandleRect: TRect; begin Result := Rect(0, 0, 0, 0); end; {$ifdef MSWINDOWS} function TArrowBar.GetScrollBarTheme: HTHEME; begin if (FScrollBarTheme = 0) then FScrollBarTheme := OpenThemeData(WindowHandle, 'SCROLLBAR'); Result := FScrollBarTheme; end; {$endif} function TArrowBar.GetTrackBoundary: TRect; begin Result := ClientRect; if Kind = sbHorizontal then GR32.InflateRect(Result, -GetButtonSize, 0) else GR32.InflateRect(Result, 0, -GetButtonSize); end; function TArrowBar.GetZone(X, Y: Integer): TRBZone; var P: TPoint; R, R1: TRect; Sz: Integer; begin Result := zNone; P := Point(X, Y); R := ClientRect; if not GR32.PtInrect(R, P) then Exit; Sz := GetButtonSize; R1 := R; if Kind = sbHorizontal then begin R1.Right := R1.Left + Sz; if GR32.PtInRect(R1, P) then Result := zBtnPrev else begin R1.Right := R.Right; R1.Left := R.Right - Sz; if GR32.PtInRect(R1, P) then Result := zBtnNext; end; end else begin R1.Bottom := R1.Top + Sz; if GR32.PtInRect(R1, P) then Result := zBtnPrev else begin R1.Bottom := R.Bottom; R1.Top := R.Bottom - Sz; if GR32.PtInRect(R1, P) then Result := zBtnNext; end; end; if Result = zNone then begin R := GetHandleRect; P := Point(X, Y); if GR32.PtInRect(R, P) then Result := zHandle else begin if Kind = sbHorizontal then begin if (X > 0) and (X < R.Left) then Result := zTrackPrev else if (X >= R.Right) and (X < ClientWidth - 1) then Result := zTrackNext; end else begin if (Y > 0) and (Y < R.Top) then Result := zTrackPrev else if (Y >= R.Bottom) and (Y < ClientHeight - 1) then Result := zTrackNext; end; end; end; end; function TArrowBar.GetZoneRect(Zone: TRBZone): TRect; const CEmptyRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); var BtnSize: Integer; Horz: Boolean; R: TRect; begin Horz := Kind = sbHorizontal; BtnSize:= GetButtonSize; case Zone of zNone: Result := CEmptyRect; zBtnPrev: begin Result := ClientRect; if Horz then Result.Right := Result.Left + BtnSize else Result.Bottom := Result.Top + BtnSize; end; zTrackPrev..zTrackNext: begin Result := GetTrackBoundary; R := GetHandleRect; if not DrawEnabled or GR32.IsRectEmpty(R) then begin R.Left := (Result.Left + Result.Right) div 2; R.Top := (Result.Top + Result.Bottom) div 2; R.Right := R.Left; R.Bottom := R.Top; end; case Zone of zTrackPrev: if Horz then Result.Right := R.Left else Result.Bottom := R.Top; zHandle: Result := R; zTrackNext: if Horz then Result.Left := R.Right else Result.Top := R.Bottom; end; end; zBtnNext: begin Result := ClientRect; if Horz then Result.Left := Result.Right - BtnSize else Result.Top := Result.Bottom - BtnSize; end; end; end; procedure TArrowBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if Button <> mbLeft then Exit; FDragZone := GetZone(X, Y); Invalidate; FStored.X := X; FStored.Y := Y; StartDragTracking; end; procedure TArrowBar.MouseLeft; begin StopHotTracking; end; procedure TArrowBar.MouseMove(Shift: TShiftState; X, Y: Integer); var NewHotZone: TRBZone; begin inherited; if (FDragZone = zNone) and (DrawEnabled) and (MouseCapture) then begin NewHotZone := GetZone(X, Y); if NewHotZone <> FHotZone then begin FHotZone := NewHotZone; if FHotZone <> zNone then StartHotTracking; Invalidate; end; end; end; procedure TArrowBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; FDragZone := zNone; Invalidate; StopDragTracking; end; procedure TArrowBar.Paint; const CPrevDirs: array [Boolean] of TRBDirection = (drUp, drLeft); CNextDirs: array [Boolean] of TRBDirection = (drDown, drRight); var BSize: Integer; ShowEnabled: Boolean; R, BtnRect, HandleRect: TRect; Horz, ShowHandle: Boolean; begin R := ClientRect; Horz := Kind = sbHorizontal; ShowEnabled := DrawEnabled; BSize := GetButtonSize; if ShowArrows then begin { left / top button } BtnRect := R; with BtnRect do if Horz then Right := Left + BSize else Bottom := Top + BSize; DoDrawButton(BtnRect, CPrevDirs[Horz], FDragZone = zBtnPrev, ShowEnabled, FHotZone = zBtnPrev); { right / bottom button } BtnRect := R; with BtnRect do if Horz then Left := Right - BSize else Top := Bottom - BSize; DoDrawButton(BtnRect, CNextDirs[Horz], FDragZone = zBtnNext, ShowEnabled, FHotZone = zBtnNext); end; if Horz then GR32.InflateRect(R, -BSize, 0) else GR32.InflateRect(R, 0, -BSize); if ShowEnabled then HandleRect := GetHandleRect else HandleRect := Rect(0, 0, 0, 0); ShowHandle := not GR32.IsRectEmpty(HandleRect); DoDrawTrack(GetZoneRect(zTrackPrev), CPrevDirs[Horz], FDragZone = zTrackPrev, ShowEnabled, FHotZone = zTrackPrev); DoDrawTrack(GetZoneRect(zTrackNext), CNextDirs[Horz], FDragZone = zTrackNext, ShowEnabled, FHotZone = zTrackNext); if ShowHandle then DoDrawHandle(HandleRect, Horz, FDragZone = zHandle, FHotZone = zHandle); end; procedure TArrowBar.SetBackgnd(Value: TRBBackgnd); begin if Value <> FBackgnd then begin FBackgnd := Value; Invalidate; end; end; procedure TArrowBar.SetBorderStyle(Value: TBorderStyle); begin if Value <> FBorderStyle then begin FBorderStyle := Value; {$IFNDEF FPC} RecreateWnd; {$ELSE} Invalidate; {$ENDIF} end; end; procedure TArrowBar.SetButtonSize(Value: Integer); begin if Value <> FButtonSize then begin FButtonSize := Value; Invalidate; end; end; procedure TArrowBar.SetHandleColor(Value: TColor); begin if Value <> FHandleColor then begin FHandleColor := Value; Invalidate; end; end; procedure TArrowBar.SetHighLightColor(Value: TColor); begin if Value <> FHighLightColor then begin FHighLightColor := Value; Invalidate; end; end; procedure TArrowBar.SetButtonColor(Value: TColor); begin if Value <> FButtonColor then begin FButtonColor := Value; Invalidate; end; end; procedure TArrowBar.SetBorderColor(Value: TColor); begin if Value <> FBorderColor then begin FBorderColor := Value; Invalidate; end; end; procedure TArrowBar.SetShadowColor(Value: TColor); begin if Value <> FShadowColor then begin FShadowColor := Value; Invalidate; end; end; procedure TArrowBar.SetKind(Value: TScrollBarKind); var Tmp: Integer; begin if Value <> FKind then begin FKind := Value; if (csDesigning in ComponentState) and not (csLoading in ComponentState) then begin Tmp := Width; Width := Height; Height := Tmp; end; Invalidate; end; end; procedure TArrowBar.SetShowArrows(Value: Boolean); begin if Value <> FShowArrows then begin FShowArrows := Value; Invalidate; end; end; procedure TArrowBar.SetShowHandleGrip(Value: Boolean); begin if Value <> FShowHandleGrip then begin FShowHandleGrip := Value; Invalidate; end; end; procedure TArrowBar.SetStyle(Value: TRBStyle); begin FStyle := Value; {$IFDEF FPC} Invalidate; {$ELSE} RecreateWnd; {$ENDIF} end; procedure TArrowBar.StartDragTracking; begin FTimer.Interval := FIRST_DELAY; FTimerMode := tmScroll; TimerHandler(Self); FTimerMode := tmScrollFirst; FTimer.Enabled := True; end; procedure TArrowBar.StartHotTracking; begin FTimer.Interval := HOTTRACK_INTERVAL; FTimerMode := tmHotTrack; FTimer.Enabled := True; end; procedure TArrowBar.StopDragTracking; begin StartHotTracking; end; procedure TArrowBar.StopHotTracking; begin FTimer.Enabled := False; FHotZone := zNone; Invalidate; end; procedure TArrowBar.TimerHandler(Sender: TObject); var Pt: TPoint; begin case FTimerMode of tmScrollFirst: begin FTimer.Interval := SCROLL_INTERVAL; FTimerMode := tmScroll; end; tmHotTrack: begin Pt := ScreenToClient(Mouse.CursorPos); if not GR32.PtInRect(ClientRect, Pt) then begin StopHotTracking; Invalidate; end; end; end; end; {$IFDEF FPC} procedure TArrowBar.WMEraseBkgnd(var Message: TLmEraseBkgnd); begin Message.Result := -1; end; procedure TArrowBar.WMNCCalcSize(var Message: TLMNCCalcSize); var Sz: Integer; begin Sz := GetBorderSize; GR32.InflateRect(Message.CalcSize_Params.rgrc[0], -Sz, -Sz); end; {$ifdef MSWINDOWS} procedure TArrowBar.WMNCPaint(var Message: TWMNCPaint); procedure DrawNCArea(ADC: HDC; const Clip: HRGN); var DC: HDC; R: TRect; begin if BorderStyle = bsNone then Exit; if ADC = 0 then DC := GetWindowDC(Handle) else DC := ADC; try GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT); finally if ADC = 0 then ReleaseDC(Handle, DC); end; end; begin DrawNCArea(0, Message.RGN); end; {$ENDIF} {$ELSE} procedure TArrowBar.WMEraseBkgnd(var Message: TWmEraseBkgnd); begin Message.Result := -1; end; procedure TArrowBar.WMNCCalcSize(var Message: TWMNCCalcSize); var Sz: Integer; begin Sz := GetBorderSize; GR32.InflateRect(Message.CalcSize_Params.rgrc[0], -Sz, -Sz); end; procedure TArrowBar.WMNCPaint(var Message: TWMNCPaint); procedure DrawNCArea(ADC: HDC; const Clip: HRGN); var DC: HDC; R: TRect; begin if BorderStyle = bsNone then Exit; if ADC = 0 then DC := GetWindowDC(Handle) else DC := ADC; try GetWindowRect(Handle, R); GR32.OffsetRect(R, -R.Left, -R.Top); DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT); finally if ADC = 0 then ReleaseDC(Handle, DC); end; end; begin DrawNCArea(0, Message.RGN); end; {$ENDIF} { TCustomRangeBar } procedure TCustomRangeBar.AdjustPosition; begin AdjustPosition(FPosition); end; procedure TCustomRangeBar.AdjustPosition(var APosition: Single); begin if (APosition > Range - EffectiveWindow) then APosition := Range - EffectiveWindow; if (APosition < 0) then APosition := 0; end; constructor TCustomRangeBar.Create(AOwner: TComponent); begin inherited; FIncrement := 8; end; procedure TCustomRangeBar.DoChanging(ANewPosition: Single; var Handled: boolean); begin if (LockUpdate > 0) then Exit; BeginLockUpdate; try if FGenChange and Assigned(FOnUserChanging) then FOnUserChanging(Self, ANewPosition, Handled); finally EndLockUpdate; end; end; function TCustomRangeBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; const OneHundredTwenteenth = 1 / 120; begin Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); if not Result then Position := Position + Increment * WheelDelta * OneHundredTwenteenth; Result := True; end; function TCustomRangeBar.DrawEnabled: Boolean; begin Result := Enabled and (Range > EffectiveWindow); end; function TCustomRangeBar.GetHandleRect: TRect; var BtnSz, ClientSz: Integer; HandleSz, HandlePos: Integer; R: TRect; Horz: Boolean; begin R := Rect(0, 0, ClientWidth, ClientHeight); Horz := Kind = sbHorizontal; BtnSz := GetButtonSize; if Horz then begin GR32.InflateRect(R, -BtnSz, 0); ClientSz := R.Right - R.Left; end else begin GR32.InflateRect(R, 0, -BtnSz); ClientSz := R.Bottom - R.Top; end; if ClientSz < 18 then begin Result := Rect(0, 0, 0, 0); Exit; end; if Range > EffectiveWindow then begin HandleSz := Round(ClientSz * EffectiveWindow / Range); if HandleSz >= MIN_SIZE then HandlePos := Round(ClientSz * Position / Range) else begin HandleSz := MIN_SIZE; HandlePos := Round((ClientSz - MIN_SIZE) * Position / (Range - EffectiveWindow)); end; Result := R; if Horz then begin Result.Left := R.Left + HandlePos; Result.Right := R.Left + HandlePos + HandleSz; end else begin Result.Top := R.Top + HandlePos; Result.Bottom := R.Top + HandlePos + HandleSz; end; end else Result := R; end; function TCustomRangeBar.IsPositionStored: Boolean; begin Result := FPosition > 0; end; procedure TCustomRangeBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Range <= EffectiveWindow then FDragZone := zNone else begin inherited; if FDragZone = zHandle then begin StopDragTracking; FPosBeforeDrag := Position; end; end; end; procedure TCustomRangeBar.MouseMove(Shift: TShiftState; X, Y: Integer); var Delta: Single; WinSz: Single; ClientSz, HandleSz: Integer; begin inherited; if (FDragZone = zHandle) and (MouseCapture) then begin WinSz := EffectiveWindow; if Range <= WinSz then Exit; if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y; if Kind = sbHorizontal then ClientSz := ClientWidth else ClientSz := ClientHeight; Dec(ClientSz, GetButtonSize * 2); if BorderStyle = bsSingle then Dec(ClientSz, 2); HandleSz := Round(ClientSz * WinSz / Range); if HandleSz < MIN_SIZE then Delta := Round(Delta * (Range - WinSz) / (ClientSz - MIN_SIZE)) else Delta := Delta * Range / ClientSz; try FGenChange := True; try Position := FPosBeforeDrag + Delta; finally FGenChange := False; end; except // Propagation of exception will cause loss of mouse capture, so we need // to emulate mouse release in order to restore internal state. if (MouseCapture) then begin MouseCapture := False; MouseUp(mbLeft, Shift, X, Y); end; raise; end; end; end; procedure TCustomRangeBar.Resize; var OldWindow: Integer; Center: Single; NewPosition: Single; begin NewPosition := FPosition; if Centered then begin OldWindow := EffectiveWindow; UpdateEffectiveWindow; if (Range > EffectiveWindow) then begin if (Range > OldWindow) and (Range <> 0) then Center := (FPosition + OldWindow * 0.5) / Range else Center := 0.5; NewPosition := Center * Range - EffectiveWindow * 0.5; end; end; Position := NewPosition; inherited; end; procedure TCustomRangeBar.SetParams(NewRange, NewWindow: Integer); var OldWindow, OldRange: Integer; Center: Single; NewPosition: Single; begin if (NewRange < 0) then NewRange := 0; if (NewWindow < 0) then NewWindow := 0; if (NewRange = FRange) and (NewWindow = EffectiveWindow) then exit; OldWindow := EffectiveWindow; OldRange := Range; FRange := NewRange; FWindow := NewWindow; UpdateEffectiveWindow; NewPosition := FPosition; if Centered and (Range > EffectiveWindow) then begin if (OldRange > OldWindow) and (OldRange <> 0) then Center := (FPosition + OldWindow * 0.5) / OldRange else Center := 0.5; NewPosition := Center * Range - EffectiveWindow * 0.5; end; Position := NewPosition; Invalidate; end; procedure TCustomRangeBar.SetPosition(Value: Single); var NewPosition: Single; Handled: boolean; begin if (Value = FPosition) then exit; NewPosition := Value; AdjustPosition(NewPosition); if (NewPosition = FPosition) then exit; Handled := False; DoChanging(NewPosition, Handled); if (Handled) then exit; FPosition := NewPosition; Invalidate; DoChange; end; procedure TCustomRangeBar.SetRange(Value: Integer); begin SetParams(Value, Window); end; procedure TCustomRangeBar.SetWindow(Value: Integer); begin SetParams(Range, Value); end; procedure TCustomRangeBar.TimerHandler(Sender: TObject); var OldPosition: Single; Pt: TPoint; function MousePos: TPoint; begin Result := ScreenToClient(Mouse.CursorPos); if Result.X < 0 then Result.X := 0; if Result.Y < 0 then Result.Y := 0; if Result.X >= ClientWidth then Result.X := ClientWidth - 1; if Result.Y >= ClientHeight then Result.Y := ClientHeight - 1 end; begin inherited; if (not MouseCapture) then Exit; FGenChange := True; try OldPosition := Position; case FDragZone of zBtnPrev: begin Position := Position - Increment; if Position = OldPosition then StopDragTracking; end; zBtnNext: begin Position := Position + Increment; if Position = OldPosition then StopDragTracking; end; zTrackNext: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackNext, zBtnNext] then Position := Position + EffectiveWindow; end; zTrackPrev: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackPrev, zBtnPrev] then Position := Position - EffectiveWindow; end; end; finally FGenChange := False; end; end; procedure TCustomRangeBar.UpdateEffectiveWindow; begin if (FWindow > 0) then FEffectiveWindow := FWindow else begin if (Kind = sbHorizontal) then FEffectiveWindow := Width else FEffectiveWindow := Height; end; end; //----------------------------------------------------------------------------// { TCustomGaugeBar } procedure TCustomGaugeBar.AdjustPosition; begin AdjustPosition(FPosition); end; procedure TCustomGaugeBar.AdjustPosition(var APosition: integer); begin if (APosition < Min) then APosition := Min else if (APosition > Max) then APosition := Max; end; constructor TCustomGaugeBar.Create(AOwner: TComponent); begin inherited; FLargeChange := 1; FMax := 100; FSmallChange := 1; end; procedure TCustomGaugeBar.DoChanging(ANewPosition: integer; var Handled: boolean); begin if (LockUpdate > 0) then Exit; BeginLockUpdate; try if FGenChange and Assigned(FOnUserChanging) then FOnUserChanging(Self, ANewPosition, Handled); finally EndLockUpdate; end; end; function TCustomGaugeBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; begin Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); if not Result then Position := Position + FSmallChange * WheelDelta div 120; Result := True; end; function TCustomGaugeBar.GetHandleRect: TRect; var Sz, HandleSz: Integer; Horz: Boolean; Pos: Integer; begin Result := GetTrackBoundary; Horz := Kind = sbHorizontal; HandleSz := GetHandleSize; if Horz then Sz := Result.Right - Result.Left else Sz := Result.Bottom - Result.Top; Pos := Round((Position - Min) / (Max - Min) * (Sz - GetHandleSize)); if Horz then begin Inc(Result.Left, Pos); Result.Right := Result.Left + HandleSz; end else begin Inc(Result.Top, Pos); Result.Bottom := Result.Top + HandleSz; end; end; function TCustomGaugeBar.GetHandleSize: Integer; var R: TRect; Sz: Integer; begin Result := HandleSize; if Result = 0 then begin if Kind = sbHorizontal then Result := ClientHeight else Result := ClientWidth; end; R := GetTrackBoundary; if Kind = sbHorizontal then Sz := R.Right - R.Left else Sz := R.Bottom - R.Top; if Sz - Result < 1 then Result := Sz - 1; if Result < 0 then Result := 0; end; procedure TCustomGaugeBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if FDragZone = zHandle then begin StopDragTracking; FPosBeforeDrag := Position; end; end; procedure TCustomGaugeBar.MouseMove(Shift: TShiftState; X, Y: Integer); var Delta: Single; R: TRect; ClientSz: Integer; begin inherited; if (FDragZone = zHandle) and (MouseCapture) then begin if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y; R := GetTrackBoundary; if Kind = sbHorizontal then ClientSz := R.Right - R.Left else ClientSz := R.Bottom - R.Top; Delta := Delta * (Max - Min) / (ClientSz - GetHandleSize); try FGenChange := True; try Position := Round(FPosBeforeDrag + Delta); finally FGenChange := False; end; except // Propagation of exception will cause loss of mouse capture, so we need // to emulate mouse release in order to restore internal state. if (MouseCapture) then begin MouseCapture := False; MouseUp(mbLeft, Shift, X, Y); end; raise; end; end; end; procedure TCustomGaugeBar.SetHandleSize(Value: Integer); begin if Value < 0 then Value := 0; if Value <> FHandleSize then begin FHandleSize := Value; Invalidate; end; end; procedure TCustomGaugeBar.SetLargeChange(Value: Integer); begin if Value < 1 then Value := 1; FLargeChange := Value; end; procedure TCustomGaugeBar.SetMax(Value: Integer); begin if (Value <= FMin) and not (csLoading in ComponentState) then Value := FMin + 1; if Value <> FMax then begin FMax := Value; Position := FPosition; Invalidate; end; end; procedure TCustomGaugeBar.SetMin(Value: Integer); begin if (Value >= FMax) and not (csLoading in ComponentState) then Value := FMax - 1; if Value <> FMin then begin FMin := Value; Position := FPosition; Invalidate; end; end; procedure TCustomGaugeBar.SetPosition(Value: Integer); var Handled: boolean; begin AdjustPosition(Value); if (Value = FPosition) then exit; Handled := False; DoChanging(Value, Handled); if (Handled) then exit; FPosition := Value; Invalidate; DoChange; end; procedure TCustomGaugeBar.SetSmallChange(Value: Integer); begin if Value < 1 then Value := 1; FSmallChange := Value; end; procedure TCustomGaugeBar.TimerHandler(Sender: TObject); var OldPosition: Single; Pt: TPoint; function MousePos: TPoint; begin Result := ScreenToClient(Mouse.CursorPos); if Result.X < 0 then Result.X := 0; if Result.Y < 0 then Result.Y := 0; if Result.X >= ClientWidth then Result.X := ClientWidth - 1; if Result.Y >= ClientHeight then Result.Y := ClientHeight - 1 end; begin inherited; if (not MouseCapture) then Exit; FGenChange := True; try OldPosition := Position; case FDragZone of zBtnPrev: begin Position := Position - SmallChange; if Position = OldPosition then StopDragTracking; end; zBtnNext: begin Position := Position + SmallChange; if Position = OldPosition then StopDragTracking; end; zTrackNext: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackNext, zBtnNext] then Position := Position + LargeChange; end; zTrackPrev: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackPrev, zBtnPrev] then Position := Position - LargeChange; end; end; finally FGenChange := False; end; end; { TArrowBarAccess } function TArrowBarAccess.GetBackgnd: TRBBackgnd; begin Result := FMaster.Backgnd; end; function TArrowBarAccess.GetButtonSize: Integer; begin Result := FMaster.ButtonSize; end; function TArrowBarAccess.GetColor: TColor; begin Result := FMaster.Color; end; function TArrowBarAccess.GetHandleColor: TColor; begin Result := FMaster.HandleColor; end; function TArrowBarAccess.GetHighLightColor: TColor; begin Result := FMaster.HighLightColor; end; function TArrowBarAccess.GetShadowColor: TColor; begin Result := FMaster.ShadowColor; end; function TArrowBarAccess.GetButtonColor: TColor; begin Result := FMaster.ButtonColor; end; function TArrowBarAccess.GetBorderColor: TColor; begin Result := FMaster.BorderColor; end; function TArrowBarAccess.GetShowArrows: Boolean; begin Result := FMaster.ShowArrows; end; function TArrowBarAccess.GetShowHandleGrip: Boolean; begin Result := FMaster.ShowHandleGrip; end; function TArrowBarAccess.GetStyle: TRBStyle; begin Result := FMaster.Style; end; procedure TArrowBarAccess.SetBackgnd(Value: TRBBackgnd); begin FMaster.Backgnd := Value; if FSlave <> nil then FSlave.Backgnd := Value; end; procedure TArrowBarAccess.SetButtonSize(Value: Integer); begin FMaster.ButtonSize := Value; if FSlave <> nil then FSlave.ButtonSize := Value; end; procedure TArrowBarAccess.SetColor(Value: TColor); begin FMaster.Color := Value; if FSlave <> nil then FSlave.Color := Value; end; procedure TArrowBarAccess.SetHandleColor(Value: TColor); begin FMaster.HandleColor := Value; if FSlave <> nil then FSlave.HandleColor := Value; end; procedure TArrowBarAccess.SetHighLightColor(Value: TColor); begin FMaster.HighLightColor := Value; if FSlave <> nil then FSlave.HighLightColor := Value; end; procedure TArrowBarAccess.SetShadowColor(Value: TColor); begin FMaster.ShadowColor := Value; if FSlave <> nil then FSlave.ShadowColor := Value; end; procedure TArrowBarAccess.SetButtonColor(Value: TColor); begin FMaster.ButtonColor := Value; if FSlave <> nil then FSlave.ButtonColor := Value; end; procedure TArrowBarAccess.SetBorderColor(Value: TColor); begin FMaster.BorderColor := Value; if FSlave <> nil then FSlave.BorderColor := Value; end; procedure TArrowBarAccess.SetShowArrows(Value: Boolean); begin FMaster.ShowArrows := Value; if FSlave <> nil then FSlave.ShowArrows := Value; end; procedure TArrowBarAccess.SetShowHandleGrip(Value: Boolean); begin FMaster.ShowHandleGrip := Value; if FSlave <> nil then FSlave.ShowHandleGrip := Value; end; procedure TArrowBarAccess.SetStyle(Value: TRBStyle); begin FMaster.Style := Value; if FSlave <> nil then FSlave.Style := Value; end; end.