88a1c9d090
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@74 8e941d3f-bd1b-0410-a28a-d453659cc2b4
324 lines
9.4 KiB
ObjectPascal
324 lines
9.4 KiB
ObjectPascal
unit RVScroll;
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF FPC}
|
|
RVLazIntf, LCLType, LCLIntf,
|
|
{$ELSE}
|
|
Windows, Messages,
|
|
{$ENDIF}
|
|
SysUtils, Classes, Forms, Controls, Graphics;
|
|
|
|
type
|
|
{ TRVScroller }
|
|
|
|
|
|
TRVScroller = class(TCustomControl)
|
|
private
|
|
FTracking: Boolean;
|
|
FFullRedraw: Boolean;
|
|
FVScrollVisible: Boolean;
|
|
FOnVScrolled: TNotifyEvent;
|
|
function GetVScrollPos: Integer;
|
|
procedure SetVScrollPos(Pos: Integer);
|
|
function GetVScrollMax: Integer;
|
|
procedure SetVScrollVisible(vis: Boolean);
|
|
protected
|
|
SmallStep, HPos, VPos, XSize, YSize: Integer;
|
|
procedure CreateParams(var Params: TCreateParams); //override;
|
|
procedure CreateWnd; override;
|
|
procedure UpdateScrollBars(XS, YS: Integer);
|
|
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
|
|
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
|
|
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
|
|
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
|
|
procedure SetVPos(p: Integer);
|
|
procedure SetHPos(p: Integer);
|
|
procedure Paint; override;
|
|
procedure ScrollChildren(dx, dy: Integer);
|
|
procedure UpdateChildren;
|
|
property FullRedraw: Boolean read FFullRedraw write FFullRedraw;
|
|
protected // to be publised properties
|
|
property Visible;
|
|
property TabStop;
|
|
property TabOrder;
|
|
property Align;
|
|
property HelpContext;
|
|
property Tracking: Boolean read FTracking write FTracking;
|
|
property VScrollVisible: Boolean read FVScrollVisible write SetVScrollVisible;
|
|
property OnVScrolled: TNotifyEvent read FOnVScrolled write FOnVScrolled;
|
|
public
|
|
{ Public declarations }
|
|
constructor Create(AOwner: TComponent);override;
|
|
procedure EraseBackground(DC: HDC); override;
|
|
procedure ScrollTo(y: Integer);
|
|
property VScrollPos: Integer read GetVScrollPos write SetVScrollPos;
|
|
property VScrollMax: Integer read GetVScrollMax;
|
|
end;
|
|
|
|
procedure Tag2Y(AControl: TControl);
|
|
|
|
implementation
|
|
{------------------------------------------------------}
|
|
procedure Tag2Y(AControl: TControl);
|
|
begin
|
|
if AControl.Tag>10000 then
|
|
AControl.Top := 10000
|
|
else
|
|
if AControl.Tag<-10000 then
|
|
AControl.Top := -10000
|
|
else
|
|
AControl.Top := AControl.Tag;
|
|
end;
|
|
{------------------------------------------------------}
|
|
constructor TRVScroller.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
TabStop := True;
|
|
FTracking := True;
|
|
FFullRedraw := False;
|
|
FVScrollVisible := True;
|
|
end;
|
|
|
|
procedure TRVScroller.EraseBackground(DC: HDC);
|
|
begin
|
|
|
|
end;
|
|
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
//inherited CreateParams(Params); //CreateWindow
|
|
Params.Style := Params.Style or WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL;
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.CreateWnd;
|
|
begin
|
|
inherited CreateWnd;
|
|
SmallStep := 10;
|
|
VPos := 0;
|
|
HPos := 0;
|
|
UpdateScrollBars(ClientWidth, (ClientHeight div SmallStep));
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.UpdateScrollBars(XS, YS: Integer);
|
|
var
|
|
ScrollInfo: TScrollInfo;
|
|
begin
|
|
XSize := XS;
|
|
YSize := YS;
|
|
ScrollInfo.cbSize := SizeOf(ScrollInfo);
|
|
ScrollInfo.fMask := SIF_ALL;
|
|
ScrollInfo.nMin := 0;
|
|
ScrollInfo.nPage := ClientHeight div SmallStep;
|
|
ScrollInfo.nMax := YSize;
|
|
ScrollInfo.nPos := VPos;
|
|
ScrollInfo.nTrackPos := 0;
|
|
SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
|
|
if not FVScrollVisible then
|
|
ShowScrollBar(Handle, SB_VERT, FVScrollVisible);
|
|
|
|
ScrollInfo.fMask := SIF_ALL;
|
|
ScrollInfo.nMin := 0;
|
|
ScrollInfo.nMax := XSize-1;
|
|
ScrollInfo.nPage := ClientWidth;
|
|
ScrollInfo.nPos := VPos;
|
|
ScrollInfo.nTrackPos := 0;
|
|
SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);
|
|
//UpdateChildren;
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.UpdateChildren;
|
|
var i: Integer;
|
|
begin
|
|
for i:=0 to ControlCount-1 do
|
|
Tag2Y(Controls[i]);
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.ScrollChildren(dx, dy: Integer);
|
|
var i: Integer;
|
|
begin
|
|
if (dx=0) and (dy=0) then exit;
|
|
for i:=0 to ControlCount-1 do begin
|
|
if dy<>0 then begin
|
|
Controls[i].Tag := Controls[i].Tag+dy;
|
|
Tag2Y(Controls[i]);
|
|
end;
|
|
if dx<>0 then Controls[i].Left := Controls[i].Left + dx;
|
|
end
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.WMHScroll(var Message: TWMHScroll);
|
|
begin
|
|
with Message do
|
|
case ScrollCode of
|
|
SB_LINEUP: SetHPos(HPos - SmallStep);
|
|
SB_LINEDOWN: SetHPos(HPos + SmallStep);
|
|
SB_PAGEUP: SetHPos(HPos-10*SmallStep);
|
|
SB_PAGEDOWN: SetHPos(HPos+10*SmallStep);
|
|
SB_THUMBPOSITION: SetHPos(Pos);
|
|
SB_THUMBTRACK: if FTracking then SetHPos(Pos);
|
|
SB_TOP: SetHPos(0);
|
|
SB_BOTTOM: SetHPos(XSize);
|
|
end;
|
|
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.WMVScroll(var Message: TWMVScroll);
|
|
begin
|
|
with Message do
|
|
case ScrollCode of
|
|
SB_LINEUP: SetVPos(VPos - 1);
|
|
SB_LINEDOWN: SetVPos(VPos + 1);
|
|
SB_PAGEUP: SetVPos(VPos-10);
|
|
SB_PAGEDOWN: SetVPos(VPos+10);
|
|
SB_THUMBPOSITION: SetVPos(Pos);
|
|
SB_THUMBTRACK: if FTracking then SetVPos(Pos);
|
|
SB_TOP: SetVPos(0);
|
|
SB_BOTTOM: SetVPos(YSize);
|
|
end;
|
|
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.WMKeyDown(var Message: TWMKeyDown);
|
|
var vScrollNotify, hScrollNotify: Integer;
|
|
begin
|
|
vScrollNotify := -1;
|
|
hScrollNotify := -1;
|
|
with Message do
|
|
case CharCode of
|
|
VK_UP:
|
|
vScrollNotify := SB_LINEUP;
|
|
VK_PRIOR:
|
|
vScrollNotify := SB_PAGEUP;
|
|
VK_NEXT:
|
|
vScrollNotify := SB_PAGEDOWN;
|
|
VK_DOWN:
|
|
vScrollNotify := SB_LINEDOWN;
|
|
VK_HOME:
|
|
vScrollNotify := SB_TOP;
|
|
VK_END:
|
|
vScrollNotify := SB_BOTTOM;
|
|
VK_LEFT:
|
|
hScrollNotify := SB_LINELEFT;
|
|
VK_RIGHT:
|
|
hScrollNotify := SB_LINERIGHT;
|
|
end;
|
|
if (vScrollNotify <> -1) then
|
|
Perform(WM_VSCROLL, vScrollNotify, 0);
|
|
if (hScrollNotify <> -1) then
|
|
Perform(WM_HSCROLL, hScrollNotify, 0);
|
|
{$IFDEF FPC}
|
|
inherited WMKeyDown(Message);
|
|
{$ELSE}
|
|
inherited;
|
|
{$ENDIF}
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.SetVPos(p: Integer);
|
|
var ScrollInfo: TScrollInfo;
|
|
oldPos: Integer;
|
|
r: TRect;
|
|
begin
|
|
OldPos := VPos;
|
|
VPos := p;
|
|
ScrollInfo.cbSize := SizeOf(ScrollInfo);
|
|
ScrollInfo.nPos := VPos;
|
|
ScrollInfo.fMask := SIF_POS;
|
|
SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
|
|
GetScrollInfo(Handle, SB_VERT, ScrollInfo);
|
|
VPos := ScrollInfo.nPos;
|
|
r := ClientRect;
|
|
if OldPos-VPos <> 0 then begin
|
|
if FFullRedraw then begin
|
|
ScrollChildren(0, (OldPos-VPos)*SmallStep);
|
|
Refresh;
|
|
end
|
|
else begin
|
|
{$IFDEF MSWINDOWS}
|
|
ScrollWindowEx(Handle, 0, (OldPos-VPos)*SmallStep, nil, @r, 0, nil, SW_INVALIDATE {or
|
|
SW_SCROLLCHILDREN});
|
|
{$ELSE}
|
|
Invalidate;
|
|
{$ENDIF}
|
|
ScrollChildren(0, (OldPos-VPos)*SmallStep);
|
|
end;
|
|
if Assigned(FOnVScrolled) then FOnVScrolled(Self);
|
|
end;
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.SetHPos(p: Integer);
|
|
var ScrollInfo: TScrollInfo;
|
|
oldPos: Integer;
|
|
r: TRect;
|
|
begin
|
|
OldPos := HPos;
|
|
HPos := p;
|
|
ScrollInfo.cbSize := SizeOf(ScrollInfo);
|
|
ScrollInfo.nPos := HPos;
|
|
ScrollInfo.fMask := SIF_POS;
|
|
SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);
|
|
GetScrollInfo(Handle, SB_HORZ, ScrollInfo);
|
|
HPos := ScrollInfo.nPos;
|
|
r := ClientRect;
|
|
if OldPos-HPos <> 0 then begin
|
|
if FFullRedraw then begin
|
|
ScrollChildren((OldPos-HPos), 0);
|
|
Refresh;
|
|
end
|
|
else begin
|
|
ScrollWindowEx(Handle, (OldPos-HPos), 0, nil, @r, 0, nil, SW_INVALIDATE{or
|
|
SW_SCROLLCHILDREN});
|
|
ScrollChildren((OldPos-HPos), 0);
|
|
end;
|
|
end;
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.Paint;
|
|
var i: Integer;
|
|
begin
|
|
Canvas.Font.Color := clRed;
|
|
Canvas.Font.Size := 2;
|
|
Canvas.FillRect(Canvas.ClipRect);
|
|
for i := Canvas.ClipRect.Top div SmallStep -1 to Canvas.ClipRect.Bottom div SmallStep +1 do
|
|
Canvas.TextOut(-HPos, i*SmallStep, IntToStr(i+VPos));
|
|
end;
|
|
{------------------------------------------------------}
|
|
procedure TRVScroller.ScrollTo(y: Integer);
|
|
begin
|
|
SetVPos(y div SmallStep);
|
|
end;
|
|
{-------------------------------------------------------}
|
|
function TRVScroller.GetVScrollPos: Integer;
|
|
begin
|
|
GetVScrollPos := VPos;
|
|
end;
|
|
{-------------------------------------------------------}
|
|
procedure TRVScroller.SetVScrollPos(Pos: Integer);
|
|
begin
|
|
SetVPos(Pos);
|
|
end;
|
|
{-------------------------------------------------------}
|
|
function TRVScroller.GetVScrollMax: Integer;
|
|
var ScrollInfo: TScrollInfo;
|
|
begin
|
|
ScrollInfo.cbSize := SizeOf(ScrollInfo);
|
|
ScrollInfo.nPos := HPos;
|
|
ScrollInfo.fMask := SIF_RANGE or SIF_PAGE;
|
|
GetScrollInfo(Handle, SB_VERT, ScrollInfo);
|
|
GetVScrollMax := ScrollInfo.nMax - Integer(ScrollInfo.nPage-1);
|
|
end;
|
|
{-------------------------------------------------------}
|
|
procedure TRVScroller.SetVScrollVisible(vis: Boolean);
|
|
begin
|
|
FVScrollVisible := vis;
|
|
ShowScrollBar(Handle, SB_VERT, vis);
|
|
end;
|
|
{-------------------------------------------------------}
|
|
procedure TRVScroller.WMGetDlgCode(var Message: TWMGetDlgCode);
|
|
begin
|
|
Message.Result := DLGC_WANTARROWS;
|
|
end;
|
|
end.
|