Archivado/Componentes.Terceros.SpTBXLib
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
f130fe4cb1
Componentes.Terceros.SpTBXLib/internal/2.4.4/1/Source/SpTBXPageScroller.pas
david 03dfd8c7c1 Importación inicial 
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SpTBXLib@4 aa3591e4-a9f2-482a-ba07-9d38a056ee4e
2010-01-19 16:32:53 +00:00

944 lines
28 KiB
ObjectPascal
Raw Blame History

unit SpTBXPageScroller;
{==============================================================================
Version 2.4.4
The contents of this file are subject to the SpTBXLib License; you may
not use or distribute this file except in compliance with the
SpTBXLib License.
A copy of the SpTBXLib License may be found in SpTBXLib-LICENSE.txt or at:
http://www.silverpointdevelopment.com/sptbxlib/SpTBXLib-LICENSE.htm
Alternatively, the contents of this file may be used under the terms of the
Mozilla Public License Version 1.1 (the "MPL v1.1"), in which case the provisions
of the MPL v1.1 are applicable instead of those in the SpTBXLib License.
A copy of the MPL v1.1 may be found in MPL-LICENSE.txt or at:
http://www.mozilla.org/MPL/
If you wish to allow use of your version of this file only under the terms of
the MPL v1.1 and not to allow others to use your version of this file under the
SpTBXLib License, indicate your decision by deleting the provisions
above and replace them with the notice and other provisions required by the
MPL v1.1. If you do not delete the provisions above, a recipient may use your
version of this file under either the SpTBXLib License or the MPL v1.1.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The initial developer of this code is Robert Lee.
Requirements:
For Delphi/C++Builder 2009 or newer:
- Jordan Russell's Toolbar 2000
http://www.jrsoftware.org
For Delphi/C++Builder 7-2007:
- Jordan Russell's Toolbar 2000
http://www.jrsoftware.org
- Troy Wolbrink's TNT Unicode Controls
http://www.tntware.com/delphicontrols/unicode/
Development notes:
- All the Windows and Delphi bugs fixes are marked with '[Bugfix]'.
- All the theme changes and adjustments are marked with '[Theme-Change]'.
History:
2 December 2009 - version 2.4.4
- No changes.
13 September 2009 - version 2.4.3
- Initial release, initial author: Kiriakos.
==============================================================================}
interface
{$BOOLEVAL OFF} // Unit depends on short-circuit boolean evaluation
uses
Windows, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Forms,
TB2Dock, TB2Item, SpTBXSkins, SpTBXItem;
const
{ New hit test constants for page scrollers }
HTSCROLLPREV = 30;
HTSCROLLNEXT = 31;
{ Page scroll button types }
PSBT_UP = 1;
PSBT_DOWN = 2;
PSBT_LEFT = 3;
PSBT_RIGHT = 4;
type
TSpTBXPageScrollerOrientation = (tpsoVertical, tpsoHorizontal);
TSpTBXPageScrollerButtons = set of (tpsbPrev, tpsbNext);
TSpTBXPageScrollerButtonType = (tpsbtUp, tpsbtDown, tpsbtLeft, tpsbtRight);
TSpTBXCustomPageScroller = class(TWinControl)
private
FAutoRangeCount: Integer;
FAutoRange: Boolean;
FAutoScroll: Boolean;
FButtonSize: Integer;
FMargin: Integer;
FOrientation: TSpTBXPageScrollerOrientation;
FPosition: Integer;
FPosRange: Integer;
FRange: Integer;
FScrollDirection: Integer;
FScrollCounter: Integer;
FScrollPending: Boolean;
FScrollTimer: TTimer;
FUpdatingButtons: Boolean;
FVisibleButtons: TSpTBXPageScrollerButtons;
procedure CalcAutoRange;
function IsRangeStored: Boolean;
procedure ScrollTimerTimer(Sender: TObject);
procedure SetButtonSize(Value: Integer);
procedure SetAutoRange(Value: Boolean);
procedure SetOrientation(Value: TSpTBXPageScrollerOrientation);
procedure SetPosition(Value: Integer);
procedure SetRange(Value: Integer);
procedure StopScrolling;
procedure ValidatePosition(var NewPos: Integer);
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
procedure WMNCMouseLeave(var Message: TMessage); message $2A2 {WM_NCMOUSELEAVE};
procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE;
procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMSpSkinChange(var Message: TMessage); message WM_SPSKINCHANGE;
protected
procedure AdjustClientRect(var Rect: TRect); override;
procedure AlignControls(AControl: TControl; var ARect: TRect); override;
function AutoScrollEnabled: Boolean; virtual;
procedure BeginScrolling(HitTest: Integer);
function CalcClientArea: TRect;
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DoSetRange(Value: Integer); virtual;
procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); virtual;
procedure HandleScrollTimer; virtual;
procedure Loaded; override;
procedure RecalcNCArea;
procedure Resizing; virtual;
procedure UpdateButtons;
property AutoRange: Boolean read FAutoRange write SetAutoRange default True;
property AutoScroll: Boolean read FAutoScroll write FAutoScroll default True;
property ButtonSize: Integer read FButtonSize write SetButtonSize default 10;
property Margin: Integer read FMargin write FMargin default 0;
property Orientation: TSpTBXPageScrollerOrientation read FOrientation write SetOrientation default tpsoVertical;
property Range: Integer read FRange write SetRange stored IsRangeStored;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure DisableAutoRange;
procedure EnableAutoRange;
procedure ScrollToCenter(ARect: TRect); overload;
procedure ScrollToCenter(AControl: TControl); overload;
property Position: Integer read FPosition write SetPosition default 0;
end;
TSpTBXPageScroller = class(TSpTBXCustomPageScroller)
published
property Align;
property Anchors;
property AutoRange;
property AutoScroll;
property ButtonSize;
property Color;
property Constraints;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property DoubleBuffered;
property Enabled;
property Ctl3D;
property Font;
property Margin;
property Orientation;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property Range;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDblClick;
property OnDockDrop;
property OnDockOver;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
{ Painting helpers }
procedure SpTBXPaintPageScrollButton(ACanvas: TCanvas; const ARect: TRect; ButtonType: TSpTBXPageScrollerButtonType; Hot: Boolean);
implementation
uses
SysUtils, TB2Common, UxTheme, Themes;
const
ScrollDelay = 300;
ScrollInterval = 75;{ TSpTBXCustomPageScroller }
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ Helpers }
function GetMinControlHeight(Control: TControl): Integer;
begin
if Control.Align = alClient then
Result := Control.Constraints.MinHeight
else
Result := Control.Height;
end;
function GetMinControlWidth(Control: TControl): Integer;
begin
if Control.Align = alClient then
Result := Control.Constraints.MinWidth
else
Result := Control.Width;
end;
procedure SpTBXPaintPageScrollButton(ACanvas: TCanvas; const ARect: TRect;
ButtonType: TSpTBXPageScrollerButtonType; Hot: Boolean);
var
R: TRect;
Flags: Integer;
X, Y, Sz: Integer;
begin
R := ARect;
case SkinManager.GetSkinType of
sknNone:
begin
if Hot then Flags := DFCS_FLAT
else Flags := 0;
case ButtonType of
tpsbtUp: Flags := Flags or DFCS_SCROLLUP;
tpsbtDown: Flags := Flags or DFCS_SCROLLDOWN;
tpsbtLeft: Flags := Flags or DFCS_SCROLLLEFT;
tpsbtRight: Flags := Flags or DFCS_SCROLLRIGHT;
end;
Windows.DrawFrameControl(ACanvas.Handle, R, DFC_SCROLL, Flags);
end;
sknWindows:
begin
if Hot then Flags := TS_PRESSED
else Flags := TS_HOT;
DrawThemeBackground(ThemeServices.Theme[teToolBar], ACanvas.Handle, TP_BUTTON, Flags, ARect, nil);
if Hot then ACanvas.Pen.Color := clBtnText;
end;
sknSkin :
begin
SpDrawXPButton(ACanvas, R, True, False, Hot, False, False, False, sknSkin);
if Hot then
ACanvas.Pen.Color := CurrentSkin.GetTextColor(skncButton, sknsHotTrack, sknSkin)
else
ACanvas.Pen.Color := CurrentSkin.GetTextColor(skncButton, sknsNormal, sknSkin);
end;
end;
if SkinManager.GetSkinType in [sknWindows, sknSkin] then begin
X := (R.Left + R.Right) div 2;
Y := (R.Top + R.Bottom) div 2;
Sz := Min(X - R.Left, Y - R.Top) * 3 div 4;
ACanvas.Brush.Color := ACanvas.Pen.Color;
case ButtonType of
tpsbtUp:
begin
Inc(Y, Sz div 2);
ACanvas.Polygon([Point(X + Sz, Y), Point(X, Y - Sz), Point(X - Sz, Y)]);
end;
tpsbtDown:
begin
Y := (R.Top + R.Bottom - 1) div 2;
Dec(Y, Sz div 2);
ACanvas.Polygon([Point(X + Sz, Y), Point(X, Y + Sz), Point(X - Sz, Y)]);
end;
tpsbtLeft:
begin
Inc(X, Sz div 2);
ACanvas.Polygon([Point(X, Y + Sz), Point(X - Sz, Y), Point(X, Y - Sz)]);
end;
tpsbtRight:
begin
X := (R.Left + R.Right - 1) div 2;
Dec(X, Sz div 2);
ACanvas.Polygon([Point(X, Y + Sz), Point(X + Sz, Y), Point(X, Y - Sz)]);
end;
end;
end;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomPageScroller }
procedure TSpTBXCustomPageScroller.AdjustClientRect(var Rect: TRect);
begin
if Orientation = tpsoVertical then
begin
if tpsbPrev in FVisibleButtons then Dec(Rect.Top, ButtonSize);
if tpsbNext in FVisibleButtons then Inc(Rect.Bottom, ButtonSize);
OffsetRect(Rect, 0, -Position);
if Range > Rect.Bottom - Rect.Top then Rect.Bottom := Rect.Top + Range;
end
else
begin
if tpsbPrev in FVisibleButtons then Dec(Rect.Left, ButtonSize);
if tpsbNext in FVisibleButtons then Inc(Rect.Right, ButtonSize);
OffsetRect(Rect, -Position, 0);
if Range > Rect.Right - Rect.Left then Rect.Right := Rect.Left + Range;
end;
end;
procedure TSpTBXCustomPageScroller.AlignControls(AControl: TControl; var ARect: TRect);
begin
CalcAutoRange;
UpdateButtons;
ARect := ClientRect;
inherited AlignControls(AControl, ARect);
end;
function TSpTBXCustomPageScroller.AutoScrollEnabled: Boolean;
begin
Result := not AutoSize and not (DockSite and UseDockManager);
end;
procedure TSpTBXCustomPageScroller.BeginScrolling(HitTest: Integer);
var
Msg: TMsg;
begin
if HitTest = HTSCROLLPREV then FScrollDirection := -1 else FScrollDirection := 1;
try
SetCapture(Handle);
FScrollCounter := FScrollDirection * 8;
FScrollPending := True;
FScrollTimer.Enabled := True;
DrawNCArea(False, 0, 0);
HandleScrollTimer;
FScrollPending := True;
FScrollTimer.Interval := ScrollDelay;
while GetCapture = Handle do begin
case Integer(GetMessage(Msg, 0, 0, 0)) of
-1: Break;
0: begin
PostQuitMessage(Msg.WParam);
Break;
end;
end;
case Msg.Message of
WM_KEYDOWN, WM_KEYUP:
if Msg.WParam = VK_ESCAPE then
Break;
WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, WM_LBUTTONUP:
begin
Break;
end;
WM_RBUTTONDOWN..WM_MBUTTONDBLCLK:;
WM_TIMER:
begin
HandleScrollTimer;
end;
else
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
finally
StopScrolling;
if GetCapture = Handle then ReleaseCapture;
end;
end;
procedure TSpTBXCustomPageScroller.CalcAutoRange;
var
I: Integer;
Bias: Integer;
NewRange, AlignMargin: Integer;
CW, CH: Integer;
Control: TControl;
begin
if (FAutoRangeCount <= 0) and AutoRange then
begin
if AutoScrollEnabled then
begin
NewRange := 0;
AlignMargin := 0;
if Position > 0 then Bias := ButtonSize
else Bias := 0;
CW := ClientWidth;
CH := ClientHeight;
DisableAlign;
for I := 0 to ControlCount - 1 do
begin
Control := Controls[I];
if Control.Visible or (csDesigning in Control.ComponentState) and
not (csNoDesignVisible in Control.ControlStyle) then
begin
if Orientation = tpsoVertical then
begin
if Control.Align in [alTop, alBottom, alClient] then
Control.Width := CW;
case Control.Align of
alTop, alNone:
if (Control.Align = alTop) or (Control.Anchors * [akTop, akBottom] = [akTop]) then
NewRange := Max(NewRange, Position + Control.Top + Control.Height + Bias);
alBottom: Inc(AlignMargin, Control.Height);
alClient: Inc(AlignMargin, GetMinControlHeight(Control));
end
end
else
begin
if Control.Align in [alLeft, alRight, alClient] then
Control.Height := CH;
case Control.Align of
alLeft, alNone:
if (Control.Align = alLeft) or (Control.Anchors * [akLeft, akRight] = [akLeft]) then
NewRange := Max(NewRange, Position + Control.Left + Control.Width + Bias);
alRight: Inc(AlignMargin, Control.Width);
alClient: Inc(AlignMargin, GetMinControlWidth(Control));
end;
end;
end;
end;
EnableAlign;
DoSetRange(NewRange + AlignMargin + Margin);
end
else DoSetRange(0);
end;
end;
function TSpTBXCustomPageScroller.CalcClientArea: TRect;
begin
Result := ClientRect;
if Orientation = tpsoVertical then
begin
if tpsbPrev in FVisibleButtons then Dec(Result.Top, ButtonSize);
if tpsbNext in FVisibleButtons then Inc(Result.Bottom, ButtonSize);
end
else
begin
if tpsbPrev in FVisibleButtons then Dec(Result.Left, ButtonSize);
if tpsbNext in FVisibleButtons then Inc(Result.Right, ButtonSize);
end;
end;
function TSpTBXCustomPageScroller.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
Result := NewHeight > FButtonSize * 3;
end;
procedure TSpTBXCustomPageScroller.ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer);
begin
// do not call inherited here
end;
constructor TSpTBXCustomPageScroller.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csAcceptsControls, csClickEvents, csDoubleClicks];
FAutoScroll := True;
FAutoRange := True;
FButtonSize := 10;
FScrollTimer := TTimer.Create(Self);
FScrollTimer.Enabled := False;
FScrollTimer.Interval := 60;
FScrollTimer.OnTimer := ScrollTimerTimer;
Width := 64;
Height := 64;
SkinManager.AddSkinNotification(Self);
end;
procedure TSpTBXCustomPageScroller.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do style := style and not (CS_HREDRAW or CS_VREDRAW);
end;
destructor TSpTBXCustomPageScroller.Destroy;
begin
SkinManager.RemoveSkinNotification(Self);
inherited;
end;
procedure TSpTBXCustomPageScroller.DisableAutoRange;
begin
Inc(FAutoRangeCount);
end;
procedure TSpTBXCustomPageScroller.DoSetRange(Value: Integer);
begin
FRange := Value;
if FRange < 0 then FRange := 0;
UpdateButtons;
end;
procedure TSpTBXCustomPageScroller.DrawNCArea(const DrawToDC: Boolean;
const ADC: HDC; const Clip: HRGN);
const
CBtns: array [TSpTBXPageScrollerOrientation, Boolean] of TSpTBXPageScrollerButtonType =
((tpsbtUp, tpsbtDown), (tpsbtLeft, tpsbtRight));
var
DC: HDC;
R, CR, BR: TRect;
ACanvas: TCanvas;
PrevBtnSize, NextBtnSize: Integer;
begin
if FVisibleButtons = [] then Exit;
if not DrawToDC then DC := GetWindowDC(Handle)
else DC := ADC;
try
GetWindowRect(Handle, R);
OffsetRect(R, -R.Left, -R.Top);
if not DrawToDC then
begin
SelectNCUpdateRgn(Handle, DC, Clip);
CR := R;
PrevBtnSize := 0;
NextBtnSize := 0;
if tpsbPrev in FVisibleButtons then PrevBtnSize := ButtonSize;
if tpsbNext in FVisibleButtons then NextBtnSize := ButtonSize;
if Orientation = tpsoVertical then
begin
Inc(CR.Top, PrevBtnSize);
Dec(CR.Bottom, NextBtnSize);
end
else
begin
Inc(CR.Left, PrevBtnSize);
Dec(CR.Right, NextBtnSize);
end;
with CR do ExcludeClipRect(DC, Left, Top, Right, Bottom);
end;
ACanvas := TCanvas.Create;
try
ACanvas.Handle := DC;
ACanvas.Brush.Color := Color;
ACanvas.FillRect(R);
if tpsbPrev in FVisibleButtons then
begin
BR := R;
if Orientation = tpsoVertical then BR.Bottom := BR.Top + ButtonSize
else BR.Right := BR.Left + ButtonSize;
SpTBXPaintPageScrollButton(ACanvas, BR, CBtns[Orientation, False],
FScrollDirection < 0);
end;
if tpsbNext in FVisibleButtons then
begin
BR := R;
if Orientation = tpsoVertical then BR.Top := BR.Bottom - ButtonSize
else BR.Left := BR.Right - ButtonSize;
SpTBXPaintPageScrollButton(ACanvas, BR, CBtns[Orientation, True],
FScrollDirection > 0);
end;
finally
ACanvas.Handle := 0;
ACanvas.Free;
end;
finally
if not DrawToDC then ReleaseDC(Handle, DC);
end;
end;
procedure TSpTBXCustomPageScroller.EnableAutoRange;
begin
if FAutoRangeCount > 0 then
begin
Dec(FAutoRangeCount);
if FAutoRangeCount = 0 then CalcAutoRange;
end;
end;
procedure TSpTBXCustomPageScroller.HandleScrollTimer;
var
Pt: TPoint;
R: TRect;
OldPosition: Integer;
OldDirection: Integer;
begin
GetCursorPos(Pt);
GetWindowRect(Handle, R);
if not PtInRect(R, Pt) then
begin
StopScrolling;
end
else if FScrollDirection = 0 then
begin
FScrollTimer.Enabled := False;
FScrollCounter := 0;
end
else
begin
OldPosition := Position;
OldDirection := FScrollDirection;
if ((FScrollDirection > 0) and (FScrollCounter < 0)) or
((FScrollDirection < 0) and (FScrollCounter > 0)) then FScrollCounter := 0;
if FScrollDirection > 0 then Inc(FScrollCounter)
else Dec(FScrollCounter);
Position := Position + FScrollCounter;
if Position = OldPosition then
begin
ReleaseCapture;
FScrollTimer.Enabled := False;
DrawNCArea(False, 0, 0);
end
else
begin
if FScrollPending or (FScrollDirection * OldDirection <= 0) or
(FScrollDirection * OldDirection <= 0) then
DrawNCArea(False, 0, 0);
end;
end;
if FScrollPending then FScrollTimer.Interval := ScrollInterval;
FScrollPending := False;
end;
function TSpTBXCustomPageScroller.IsRangeStored: Boolean;
begin
Result := not AutoRange;
end;
procedure TSpTBXCustomPageScroller.Loaded;
begin
inherited;
UpdateButtons;
end;
procedure TSpTBXCustomPageScroller.RecalcNCArea;
begin
SetWindowPos(Handle, 0, 0, 0, 0, 0,
SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE);
end;
procedure TSpTBXCustomPageScroller.Resizing;
begin
// do nothing by default
end;
procedure TSpTBXCustomPageScroller.ScrollTimerTimer(Sender: TObject);
begin
HandleScrollTimer;
end;
procedure TSpTBXCustomPageScroller.ScrollToCenter(ARect: TRect);
var
X, Y: Integer;
begin
if Orientation = tpsoVertical then
begin
if ARect.Bottom - ARect.Top < Range then Y := (ARect.Top + ARect.Bottom) div 2
else Y := ARect.Top;
Position := Position + Y - Height div 2;
end
else
begin
if ARect.Right - ARect.Left < Range then X := (ARect.Left + ARect.Right) div 2
else X := ARect.Left;
Position := Position + X - Width div 2;
end;
end;
procedure TSpTBXCustomPageScroller.ScrollToCenter(AControl: TControl);
var
R: TRect;
begin
R := AControl.ClientRect;
R.TopLeft := ScreenToClient(AControl.ClientToScreen(R.TopLeft));
R.BottomRight := ScreenToClient(AControl.ClientToScreen(R.BottomRight));
ScrollToCenter(R);
end;
procedure TSpTBXCustomPageScroller.SetAutoRange(Value: Boolean);
begin
if FAutoRange <> Value then
begin
FAutoRange := Value;
if Value then CalcAutoRange else Range := 0;
end;
end;
procedure TSpTBXCustomPageScroller.SetButtonSize(Value: Integer);
begin
if FButtonSize <> Value then
begin
FButtonSize := Value;
UpdateButtons;
end;
end;
procedure TSpTBXCustomPageScroller.SetOrientation(Value: TSpTBXPageScrollerOrientation);
begin
if Orientation <> Value then
begin
FOrientation := Value;
Realign;
end;
end;
procedure TSpTBXCustomPageScroller.SetPosition(Value: Integer);
var
OldPos: Integer;
begin
if csReading in ComponentState then FPosition := Value
else
begin
ValidatePosition(Value);
if FPosition <> Value then
begin
OldPos := FPosition;
FPosition := Value;
if OldPos > 0 then Inc(OldPos, ButtonSize);
if Value > 0 then Inc(Value, ButtonSize);
if Orientation = tpsoHorizontal then ScrollBy(OldPos - Value, 0)
else ScrollBy(0, OldPos - Value);
UpdateButtons;
end;
end;
end;
procedure TSpTBXCustomPageScroller.SetRange(Value: Integer);
begin
FAutoRange := False;
DoSetRange(Value);
end;
procedure TSpTBXCustomPageScroller.StopScrolling;
begin
if (FScrollDirection <> 0) or (FScrollCounter <> 0) or (FScrollTimer.Enabled) then
begin
FScrollDirection := 0;
FScrollCounter := 0;
FScrollTimer.Enabled := False;
if HandleAllocated and IsWindowVisible(Handle) then DrawNCArea(False, 0, 0);
end;
end;
procedure TSpTBXCustomPageScroller.UpdateButtons;
var
Sz: Integer;
OldVisibleButtons: TSpTBXPageScrollerButtons;
RealignNeeded: Boolean;
begin
RealignNeeded := False;
if not FUpdatingButtons and HandleAllocated then
try
FUpdatingButtons := True;
if Orientation = tpsoHorizontal then Sz := Width
else Sz := Height;
OldVisibleButtons := FVisibleButtons;
FVisibleButtons := [];
FPosRange := Range - Sz;
if FPosRange < 0 then FPosRange := 0;
if FPosition > FPosRange - 1 then
begin
FPosition := FPosRange;
RealignNeeded := True;
end;
if Sz > ButtonSize * 3 then
begin
if Position > 0 then Include(FVisibleButtons, tpsbPrev);
if Range - Position > Sz then Include(FVisibleButtons, tpsbNext);
end;
if FVisibleButtons <> OldVisibleButtons then
begin
RecalcNCArea;
RealignNeeded := True;
end;
finally
FUpdatingButtons := False;
if RealignNeeded then Realign;
end;
end;
procedure TSpTBXCustomPageScroller.ValidatePosition(var NewPos: Integer);
begin
if NewPos < 0 then NewPos := 0;
if NewPos > FPosRange then NewPos := FPosRange;
end;
procedure TSpTBXCustomPageScroller.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
if Color = clNone then
begin
SpDrawParentBackground(Self, Message.DC, ClientRect);
Message.Result := 1;
end
else inherited;
end;
procedure TSpTBXCustomPageScroller.WMMouseMove(var Message: TWMMouseMove);
begin
if AutoScroll then StopScrolling;
inherited;
end;
procedure TSpTBXCustomPageScroller.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
with Message.CalcSize_Params^ do
begin
if Orientation = tpsoVertical then
begin
if tpsbPrev in FVisibleButtons then Inc(rgrc[0].Top, ButtonSize);
if tpsbNext in FVisibleButtons then Dec(rgrc[0].Bottom, ButtonSize);
end
else
begin
if tpsbPrev in FVisibleButtons then Inc(rgrc[0].Left, ButtonSize);
if tpsbNext in FVisibleButtons then Dec(rgrc[0].Right, ButtonSize);
end;
Message.Result := 0;
end;
end;
procedure TSpTBXCustomPageScroller.WMNCHitTest(var Message: TWMNCHitTest);
var
Pt: TPoint;
R: TRect;
begin
DefaultHandler(Message);
with Message do if Result <> HTCLIENT then
begin
Pt := SmallPointToPoint(Pos);
GetWindowRect(Handle, R);
if PtInRect(R, Pt) then
begin
if (tpsbPrev in FVisibleButtons) then
begin
if Orientation = tpsoVertical then
begin
if Pt.Y < R.Top + ButtonSize then Result := HTSCROLLPREV
end
else
begin
if Pt.X < R.Left + ButtonSize then Result := HTSCROLLPREV
end;
end;
if (tpsbNext in FVisibleButtons) then
begin
if Orientation = tpsoVertical then
begin
if Pt.Y >= R.Bottom - ButtonSize then Result := HTSCROLLNEXT;
end
else
begin
if Pt.X >= R.Right - ButtonSize then Result := HTSCROLLNEXT;
end;
end;
end;
end;
end;
procedure TSpTBXCustomPageScroller.WMNCLButtonDown(var Message: TWMNCLButtonDown);
begin
if (Win32MajorVersion >= 5) or
(Win32MajorVersion = 4) and (Win32MinorVersion >= 10) then
CallTrackMouseEvent(Handle, TME_LEAVE or $10 {TME_NONCLIENT});
if not AutoScroll and (Message.HitTest in [HTSCROLLPREV, HTSCROLLNEXT]) then
BeginScrolling(Message.HitTest)
else
inherited;
end;
procedure TSpTBXCustomPageScroller.WMNCMouseLeave(var Message: TMessage);
begin
if AutoScroll then StopScrolling;
inherited;
end;
procedure TSpTBXCustomPageScroller.WMNCMouseMove(var Message: TWMNCMouseMove);
var
OldScrollDirection: Integer;
begin
if (Win32MajorVersion >= 5) or
(Win32MajorVersion = 4) and (Win32MinorVersion >= 10) then
CallTrackMouseEvent(Handle, TME_LEAVE or $10 {TME_NONCLIENT});
if AutoScroll then
begin
OldScrollDirection := FScrollDirection;
case Message.HitTest of
HTSCROLLPREV: FScrollDirection := -1;
HTSCROLLNEXT: FScrollDirection := 1;
else
StopScrolling;
inherited;
Exit;
end;
if OldScrollDirection <> FScrollDirection then
begin
FScrollCounter := 0;
FScrollPending := True;
FScrollTimer.Interval := ScrollDelay;
FScrollTimer.Enabled := True;
DrawNCArea(False, 0, 0);
end;
end;
end;
procedure TSpTBXCustomPageScroller.WMNCPaint(var Message: TMessage);
begin
DrawNCArea(False, 0, HRGN(Message.WParam));
end;
procedure TSpTBXCustomPageScroller.WMSize(var Message: TWMSize);
begin
FUpdatingButtons := True;
try
CalcAutoRange;
finally
FUpdatingButtons := False;
end;
Inc(FAutoRangeCount);
inherited;
Resizing;
Dec(FAutoRangeCount);
end;
procedure TSpTBXCustomPageScroller.WMSpSkinChange(var Message: TMessage);
begin
if HandleAllocated then
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_ERASE);
end;
end.
Reference in New Issue View Git Blame Copy Permalink