Archivado/Componentes.Terceros.Mustangpeak
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
Componentes.Terceros.Mustan.../official/1.7.0/EasyListview/Source/EasyScrollFrame.pas
david 778b05bf9f Importación inicial 
- Mustangpeak Common Library - 1.7.0
  - EasyListview - 1.7.0

git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.Mustangpeak@2 60b41242-d4b9-2247-b156-4ccd40706241
2007-09-11 08:33:06 +00:00

440 lines
13 KiB
ObjectPascal
Raw Permalink Blame History

unit EasyScrollFrame;
// Version 1.7.0
//
// 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/
//
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
//
// 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.
//
// The initial developer of this code is Jim Kueneman <jimdk@mindspring.com>
//
// Special thanks to the following in no particular order for their help/support/code
// Danijel Malik, Robert Lee, Werner Lehmann, Alexey Torgashin, Milan Vandrovec
//----------------------------------------------------------------------------
interface
{$I Compilers.inc}
{$I Options.inc}
{$I ..\Include\Addins.inc}
uses
Windows,
Messages,
SysUtils,
Classes,
Graphics,
{$IFDEF COMPILER_7_UP}
Themes,
UxTheme,
{$ELSE}
{$IFDEF USETHEMES}
TmSchema,
UxTheme,
{$ENDIF}
{$ENDIF}
Controls,
MPCommonObjects,
MPCommonUtilities;
const
TIMER_AUTOSCROLLDELAY = 1003;
TIMER_AUTOSCROLL = 1004;
type
TEasyScrollButtonState = (
sbsHovering, // The mouse is hovering over the button
sbsDown, // The button is down
sbsAutoClick, // The button is down for a predetermined time and is autoscrolling at some time interval
sbsAutoScrollTimerRunning // Timer is running for AutoClick
);
TEasyScrollButtonStates = set of TEasyScrollButtonState;
TEasyScrollButtonDir = (
sbdLeft, // Arrow points Left
sbdUp, // Arrow points Up
sbdDown, // Arrow points Down
sbdRight // Arrow points right
);
TEasyTimerType = (
ettAutoScrollDelay,
ettAutoScroll
);
TCustomEasyScrollButton = class(TCommonCanvasControl)
private
FArrowSize: Integer;
FAutoScroll: Boolean;
FAutoScrollTime: Integer;
FAutoScrollTimeOut: Integer;
FDirection: TEasyScrollButtonDir;
FFlat: Boolean;
FOnClick: TNotifyEvent;
FState: TEasyScrollButtonStates;
FTimerID: THandle;
FTimerStub: Pointer;
procedure SetDirection(const Value: TEasyScrollButtonDir);
procedure SetFlat(const Value: Boolean);
protected
procedure DoClick; virtual;
procedure DoPaintRect(ACanvas: TCanvas; WindowClipRect: TRect; SelectedOnly: Boolean); virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure SetEnabled(Value: Boolean); override;
procedure StartAutoScrollTimer(TimerType: TEasyTimerType);
procedure StopAutoScrollTimer(FreeStub: Boolean);
procedure TimerProc(Window: HWnd; uMsg: UINT; idEvent: UINT; dwTime: DWORD); stdcall;
procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
property ArrowSize: Integer read FArrowSize write FArrowSize default 12;
property AutoScroll: Boolean read FAutoScroll write FAutoScroll default False;
property AutoScrollDelay: Integer read FAutoScrollTimeOut write FAutoScrollTimeOut default 1000;
property AutoScrollTime: Integer read FAutoScrollTime write FAutoScrollTime default 100;
property Direction: TEasyScrollButtonDir read FDirection write SetDirection default sbdLeft;
property Flat: Boolean read FFlat write SetFlat default False;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
property State: TEasyScrollButtonStates read FState write FState;
property TimerID: THandle read FTimerID write FTimerID;
property TimerStub: Pointer read FTimerStub write FTimerStub;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
end;
TEasyScrollButton = class(TCustomEasyScrollButton)
public
property State;
published
property Action;
property ActionLink;
property Align;
property Anchors;
property ArrowSize;
property AutoScroll;
property AutoScrollDelay;
property AutoScrollTime;
property AutoSize;
property BorderWidth;
property Constraints;
property Direction;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Flat;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
{$IFDEF COMPILER_5_UP}
property OnContextPopup;
{$ENDIF}
property OnDblClick;
property OnDockDrop;
property OnDockOver;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Themed;
property Visible;
end;
implementation
{ TEasyScrollButton }
constructor TCustomEasyScrollButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoScrollDelay := 1000;
AutoScrollTime := 100;
Width := GetSystemMetrics(SM_CXHSCROLL);
Height := GetSystemMetrics(SM_CYHSCROLL);
ArrowSize := 12
end;
destructor TCustomEasyScrollButton.Destroy;
begin
inherited Destroy;
end;
procedure TCustomEasyScrollButton.DoClick;
begin
if Assigned(OnClick) then
OnClick(Self)
end;
procedure TCustomEasyScrollButton.DoPaintRect(ACanvas: TCanvas; WindowClipRect: TRect; SelectedOnly: Boolean);
procedure DrawWithoutThemes;
var
uState: Cardinal;
begin
uState := 0;
if (sbsHovering in State) and not (sbsDown in State) then
begin
case Direction of
sbdLeft: uState := DFCS_SCROLLLEFT;
sbdUp: uState := DFCS_SCROLLUP ;
sbdDown: uState := DFCS_SCROLLDOWN;
sbdRight: uState := DFCS_SCROLLRIGHT;
end
end else
if (sbsDown in State) and (sbsHovering in State) then
begin
case Direction of
sbdLeft: uState := DFCS_SCROLLLEFT or DFCS_PUSHED;
sbdUp: uState := DFCS_SCROLLUP or DFCS_PUSHED;
sbdDown: uState := DFCS_SCROLLDOWN or DFCS_PUSHED;
sbdRight: uState := DFCS_SCROLLRIGHT or DFCS_PUSHED;
end
end else
begin
case Direction of
sbdLeft: uState := DFCS_SCROLLLEFT;
sbdUp: uState := DFCS_SCROLLUP;
sbdDown: uState := DFCS_SCROLLDOWN;
sbdRight: uState := DFCS_SCROLLRIGHT;
end
end;
if Flat then
uState := uState or DFCS_FLAT;
if not Enabled then
uState := uState or DFCS_INACTIVE;
DrawFrameControl(ACanvas.Handle, ClientRect, DFC_SCROLL, uState);
end;
{$IFDEF USETHEMES}
var
Part, uState: Longword;
{$ENDIF}
begin
{$IFDEF USETHEMES}
if DrawWithThemes then
begin
uState := 0;
Part := SBP_ARROWBTN;
if Enabled then
begin
if (sbsHovering in State) and not (sbsDown in State) then
begin
case Direction of
sbdLeft: uState := ABS_LEFTHOT;
sbdUp: uState := ABS_UPHOT;
sbdDown: uState := ABS_DOWNHOT;
sbdRight: uState := ABS_RIGHTHOT;
end
end else
if (sbsDown in State) and (sbsHovering in State) then
begin
case Direction of
sbdLeft: uState := ABS_LEFTPRESSED;
sbdUp: uState := ABS_UPPRESSED;
sbdDown: uState := ABS_DOWNPRESSED;
sbdRight: uState := ABS_RIGHTPRESSED;
end
end else
begin
case Direction of
sbdLeft: uState := ABS_LEFTNORMAL;
sbdUp: uState := ABS_UPNORMAL;
sbdDown: uState := ABS_DOWNNORMAL;
sbdRight: uState := ABS_RIGHTNORMAL;
end
end;
end else
begin
case Direction of
sbdLeft: uState := ABS_LEFTDISABLED;
sbdUp: uState := ABS_UPDISABLED;
sbdDown: uState := ABS_DOWNDISABLED;
sbdRight: uState := ABS_RIGHTDISABLED;
end
end;
DrawThemeBackground(Themes.ScrollbarTheme, ACanvas.Handle,
Part, uState, ClientRect, @WindowClipRect);
end else
DrawWithOutThemes;
{$ELSE}
DrawWithoutThemes;
{$ENDIF}
end;
procedure TCustomEasyScrollButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if not (sbsDown in State) then
begin
Include(FState, sbsDown);
StartAutoScrollTimer(ettAutoScrollDelay);
Invalidate
end
end;
procedure TCustomEasyScrollButton.MouseMove(Shift: TShiftState; X: Integer; Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
if PtInRect(ClientRect, Point(X, Y)) then
begin
if not (sbsHovering in State) then
begin
Include(FState, sbsHovering);
Invalidate
end;
Mouse.Capture := Handle
end else
begin
if sbsHovering in State then
begin
Exclude(FState, sbsHovering);
StopAutoScrollTimer(True);
Invalidate
end;
if [sbsDown, sbsHovering] * State = [] then
begin
if Mouse.Capture = Handle then
Mouse.Capture := 0
end
end
end;
procedure TCustomEasyScrollButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if PtInRect(ClientRect, Point(X, Y)) and (sbsDown in State) then
DoClick;
if sbsDown in State then
begin
StopAutoScrollTimer(True);
Exclude(FState, sbsDown);
Invalidate
end
end;
procedure TCustomEasyScrollButton.SetDirection(const Value: TEasyScrollButtonDir);
begin
if FDirection <> Value then
begin
FDirection := Value;
Invalidate
end
end;
procedure TCustomEasyScrollButton.SetEnabled(Value: Boolean);
begin
inherited;
Invalidate
end;
procedure TCustomEasyScrollButton.SetFlat(const Value: Boolean);
begin
if FFlat <> Value then
begin
FFlat := Value;
Invalidate
end
end;
procedure TCustomEasyScrollButton.StartAutoScrollTimer(TimerType: TEasyTimerType);
begin
if AutoScroll then
begin
if not Assigned(TimerStub) then
TimerStub := CreateStub(Self, @TCustomEasyScrollButton.TimerProc);
if TimerType = ettAutoScrollDelay then
TimerID := SetTimer(Handle, TIMER_AUTOSCROLLDELAY, AutoScrollDelay, TimerStub)
else
TimerID := SetTimer(Handle, TIMER_AUTOSCROLL, AutoScrollTime, TimerStub);
Include(FState, sbsAutoScrollTimerRunning);
end
end;
procedure TCustomEasyScrollButton.StopAutoScrollTimer(FreeStub: Boolean);
begin
if sbsAutoScrollTimerRunning in State then
begin
if KillTimer(Handle, TimerID) then
begin
TimerID := 0;
Exclude(FState, sbsAutoScrollTimerRunning);
if FreeStub then
begin
DisposeStub(FTimerStub);
TimerStub := nil;
end
end else
Exception.Create('Can not Destroy Scroll Button Timer');
end
end;
procedure TCustomEasyScrollButton.TimerProc(Window: HWnd; uMsg: UINT; idEvent: UINT; dwTime: DWORD);
begin
case idEvent of
TIMER_AUTOSCROLLDELAY:
begin
StopAutoScrollTimer(False);
StartAutoScrollTimer(ettAutoScroll);
end;
TIMER_AUTOSCROLL:
begin
DoClick
end;
end
end;
procedure TCustomEasyScrollButton.WMPaint(var Msg: TWMPaint);
var
PaintInfo: TPaintStruct;
begin
if UpdateCount = 0 then
begin
BeginPaint(Handle, PaintInfo);
try
if not IsRectEmpty(PaintInfo.rcPaint) then
begin
// Paint the rectangle that is needed
Canvas.Handle := Msg.DC;
DoPaintRect(Canvas, PaintInfo.rcPaint, False);
end
finally
// Release the Handle from the canvas so that EndPaint may dispose of the DC as it sees fit
EndPaint(Handle, PaintInfo);
end
end
end;
end.
Reference in New Issue View Git Blame Copy Permalink