expertcad/POWERCAD30/UNITS/PCScrollBar.pas

unit PCScrollBar;

interface

uses Classes, Controls, Messages, Forms, StdCtrls, Windows, ExtCtrls,SysUtils;


type
//== TPCScrollBar =============================================================
	TPCScrollBarInc = 1..2147483647;
	TPCScrollBar = class(TWinControl)
	private
		FKind       : TScrollBarKind;
		FPageSize   : Cardinal;
		FPosition   : Integer;
		FMin        : Integer;
		FMax        : Integer;
		FSmallChange: TPCScrollBarInc;
		FLargeChange: TPCScrollBarInc;
		FOnChange   : TNotifyEvent;
		FOnScroll   : TScrollEvent;
		procedure DoScroll(var Message: TWMScroll);
		procedure SetKind(Value: TScrollBarKind);
		procedure SetMax(Value: Integer);
		procedure SetMin(Value: Integer);
		procedure SetPageSize(Value: Cardinal);
		procedure SetPosition(Value: Integer);
		procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  protected
		procedure CreateParams(var Params: TCreateParams); override;
		procedure CreateWnd; override;
		procedure Change; dynamic;
		procedure Scroll(ScrollCode: TScrollCode; var Pos: Integer); dynamic;
	public
		constructor Create(AOwner: TComponent); override;
		procedure SetParams(APosition, AMin, AMax: Integer);
		procedure SetParams32(APosition, AMin, AMax: Integer; APage: Cardinal);
	published
		property Ctl3D;
		property DragCursor;
		property DragMode;
		property Enabled;
		property Kind: TScrollBarKind read FKind write SetKind default sbHorizontal;
		property LargeChange: TPCScrollBarInc read FLargeChange write FLargeChange default 1;
		property Max: Integer read FMax write SetMax default 100;
		property Min: Integer read FMin write SetMin default 0;
		property PageSize: Cardinal read FPageSize write SetPageSize default 0;
		property ParentCtl3D;
		property ParentShowHint;
		property PopupMenu;
		property Position: Integer read FPosition write SetPosition default 0;
		property ShowHint;
		property SmallChange: TPCScrollBarInc read FSmallChange write FSmallChange default 1;
		property TabOrder;
		property TabStop default True;
		property Visible;
		property OnChange: TNotifyEvent read FOnChange write FOnChange;
		property OnDragDrop;
		property OnDragOver;
		property OnEndDrag;
		property OnEnter;
		property OnExit;
		property OnKeyDown;
		property OnKeyPress;
		property OnKeyUp;
		property OnScroll: TScrollEvent read FOnScroll write FOnScroll;
		property OnStartDrag;
	end;



//*****************************************************************************
implementation
{$R *.DCR}
uses Consts;

//== TPCScrollBar =============================================================
constructor TPCScrollBar.Create(AOwner: TComponent);
begin
	inherited create(AOwner);
	FKind        := sbHorizontal;
	Width        := 121;
	Height       := GetSystemMetrics(SM_CYHSCROLL);
	ControlStyle := [csFramed, csDoubleClicks];
	TabStop      := True;
	FPosition    := 0;
	FMin         := 0;
	FMax         := 100;
	FSmallChange := 1;
	FLargeChange := 1;
	FPageSize    := 0;    {this gives the classical thumb}
end;

procedure TPCScrollBar.CreateParams(var Params: TCreateParams);
const
  Kinds: array[TScrollBarKind] of LongInt = (SBS_HORZ, SBS_VERT);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'SCROLLBAR');
  with Params do Style := Style or Kinds[FKind];
end;

procedure TPCScrollBar.CreateWnd;
var
	ScrollInfo: TScrollInfo;
begin
	inherited CreateWnd;
	ScrollInfo.cbSize := Sizeof (ScrollInfo);
	ScrollInfo.fMask  := SIF_PAGE or SIF_POS or SIF_RANGE;
	ScrollInfo.nPage  := FPageSize;
	ScrollInfo.nMin   := FMin;
	ScrollInfo.nMax   := FMax;
	ScrollInfo.nPos   := FPosition;
	SetScrollInfo (Handle, SB_CTL, ScrollInfo, True);
end;

procedure TPCScrollBar.SetKind(Value: TScrollBarKind);
begin
	if FKind <> Value then begin
    FKind := Value;
		if not (csLoading in ComponentState) then SetBounds(Left, Top, Height, Width);
    RecreateWnd;
  end;
end;

procedure TPCScrollBar.SetParams(APosition, AMin, AMax: Integer);
begin
	SetParams32(APosition, AMin, AMax, FPageSize);
end;

procedure TPCScrollBar.SetParams32(APosition, AMin, AMax: Integer; APage: Cardinal);
var
	ScrollInfo: TScrollInfo;
begin
	{clip values to valid ranges}
	if AMax < AMin then raise EInvalidOperation.CreateRes(0);
	if APage > AMax-AMin+1 then APage := AMax-AMin+1;
	if APosition < AMin then APosition := AMin;
	if APage > 1 then begin
		if APosition > AMax-APage+1 then APosition := AMax-APage+1;
	end else
		if APosition > AMax then APosition := AMax;
	{set mask for parameters to be changed}
	ScrollInfo.fMask := 0;
	if (FMin <> AMin) or (FMax <> AMax) then
		ScrollInfo.fMask := ScrollInfo.fMask or SIF_RANGE;
	if FPosition <> APosition then
		ScrollInfo.fMask := ScrollInfo.fMask or SIF_POS;
	if FPageSize <> APage then
		ScrollInfo.fMask := ScrollInfo.fMask or SIF_PAGE;
	{change parameters}
	ScrollInfo.cbSize := Sizeof(ScrollInfo);
	ScrollInfo.nPos   := APosition;
	ScrollInfo.nMin   := AMin;
	ScrollInfo.nMax   := AMax;
	ScrollInfo.nPage  := APage;
	if HandleAllocated then SetScrollInfo (Handle, SB_CTL, ScrollInfo, True);
	{remember changes}
	FMin      := AMin;
	FMax      := AMax;
	FPageSize := APage;
	if FPosition <> APosition then begin
		FPosition := APosition;
		Change;
	end;
end;

procedure TPCScrollBar.SetPosition(Value: Integer);
begin
	SetParams32(Value, FMin, FMax, FPageSize);
end;

procedure TPCScrollBar.SetMin(Value: Integer);
begin
	SetParams32(FPosition, Value, FMax, FPageSize);
end;

procedure TPCScrollBar.SetMax(Value: Integer);
begin
	SetParams32(FPosition, FMin, Value, FPageSize);
end;

procedure TPCScrollBar.SetPageSize (Value: Cardinal);
begin
	SetParams32(FPosition, FMin, FMax, Value);
end;

procedure TPCScrollBar.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TPCScrollBar.Scroll(ScrollCode: TScrollCode; var Pos: Integer);
begin
  if Assigned(FOnScroll) then FOnScroll(Self, ScrollCode, Pos);
end;

procedure TPCScrollBar.DoScroll(var Message: TWMScroll);
var
	ScrollInfo: TScrollInfo;
	NewPos: Integer;
begin
	with Message do
  begin
		NewPos := FPosition;
		case TScrollCode(ScrollCode) of
			scLineUp  : Dec(NewPos, FSmallChange);
			scLineDown: Inc(NewPos, FSmallChange);
			scPageUp  : Dec(NewPos, FLargeChange);
			scPageDown: Inc(NewPos, FLargeChange);
			scTrack   : begin
            				ScrollInfo.cbSize := Sizeof (ScrollInfo);
                		ScrollInfo.fMask := SIF_TRACKPOS;
            				GetScrollInfo (Handle, SB_CTL, ScrollInfo);
            				NewPos := ScrollInfo.nTrackPos;
            			end;
			scTop   : NewPos := FMin;
			scBottom: NewPos := FMax;
		end;
		if NewPos < FMin then
      NewPos := FMin;
		if FPageSize > 1 then
    begin
			if NewPos > FMax - FPageSize + 1 then
        NewPos := FMax - FPageSize + 1;
		end
    else
		if NewPos > FMax then
      NewPos := FMax;
		Scroll(TScrollCode(ScrollCode), NewPos);
		SetPosition(NewPos);
	end;
end;

procedure TPCScrollBar.CNHScroll(var Message: TWMHScroll);
begin
  DoScroll(Message);
end;

procedure TPCScrollBar.CNVScroll(var Message: TWMVScroll);
begin
  DoScroll(Message);
end;


end.