lazarus/lcl/include/scrollbar.inc

{%MainUnit ../stdctrls.pp}

{
 TCustomScrollBar

 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL, included in this distribution,        *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************
}



{------------------------------------------------------------------------------}
{  function TCustomScrollBar.Create                                                      }
{------------------------------------------------------------------------------}
constructor TCustomScrollBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fCompStyle := csScrollBar;
  Width := 121;
  Height := GetSystemMetrics(SM_CYHSCROLL);
  SetBounds(0,0,width,height);
  TabStop := True;
  ControlStyle := ControlStyle + [csFramed, csDoubleClicks, csOpaque]
                               - [csAcceptsControls, csDoubleClicks,
                                  csCaptureMouse, csSetCaption];
  FKind := sbHorizontal;
  FPosition := 0;
  FMin := 0;
  FMax := 100;
  FSmallChange := 1;
  FLargeChange := 1;
end;

procedure TCustomScrollBar.CreateParams(var Params: TCreateParams);
const
  Kinds: array[TScrollBarKind] of DWORD = (SBS_HORZ, SBS_VERT);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'SCROLLBAR');
  Params.Style := Params.Style or Kinds[FKind];
  if FKind = sbVertical then
      Params.Style := Params.Style or SBS_LEFTALIGN;
  FRTLFactor := 1
end;

procedure TCustomScrollBar.CreateWnd;
var
  ScrollInfo: TScrollInfo;
begin
  inherited CreateWnd;
  if not HandleAllocated then RaiseGDBException('TCustomScrollBar.CreateWnd HandleAllocated=false');
  ScrollInfo.cbSize := SizeOf(ScrollInfo);
  ScrollInfo.nMin := FMin;
  ScrollInfo.nMax := FMax + FPageSize;
  ScrollInfo.nPage := FPageSize;
  ScrollInfo.fMask := SIF_PAGE or SIF_Range;
  SetScrollInfo(Handle, SB_CTL, ScrollInfo, False);
  if NotRightToLeft then
    SetScrollPos(Handle, SB_CTL, FPosition, True)
  else
    SetScrollPos(Handle, SB_CTL, FMax - FPosition, True);
end;

function TCustomScrollBar.NotRightToLeft: Boolean;
begin
  Result := True;
end;

procedure TCustomScrollBar.SetKind(Value: TScrollBarKind);
var
  OldWidth: Integer;
  OldHeight: Integer;
begin
  if FKind <> Value then begin
    FKind := Value;
    // switch width and height, but not when loading, because we assume that
    // the lfm contains a consistent combination of kind and (width, height)
    if not (csLoading in ComponentState) then begin
      OldWidth:=Width;
      OldHeight:=Height;
      // TODO: Remove RecreateWnd
      if HandleAllocated then
        RecreateWnd(Self)
      else
        Constraints.UpdateInterfaceConstraints;
      SetBounds(Left,Top,OldHeight,OldWidth);
    end;
  end;
end;

procedure TCustomScrollBar.SetParams(APosition, AMin, AMax, APageSize: Integer);
var
  ScrollInfo: TScrollInfo;
begin
  if AMax < AMin then
    raise EInvalidOperation.Create(rsScrollBarOutOfRange);
  if APosition < AMin then APosition := AMin;
  if APosition > AMax then APosition := AMax;
  if APageSize < 0 then APageSize := 0;
  if (FMin <> AMin) or (FMax <> AMax) or (APageSize <> FPageSize) then
  begin
    FMin := AMin;
    FMax := AMax;
    FPageSize := APageSize;
    if HandleAllocated then
    begin
      ScrollInfo.fMask := SIF_PAGE or SIF_Range;
      ScrollInfo.nMin := AMin;
      ScrollInfo.nMax := AMax + APageSize;
      ScrollInfo.nPage := APageSize;
      SetScrollInfo(Handle, SB_CTL, ScrollInfo, FPosition = APosition);
    end;
  end;
  if FPosition <> APosition then
  begin
    FPosition := APosition;
    if HandleAllocated then
      if NotRightToLeft then
        SetScrollPos(Handle, SB_CTL, FPosition, True)
      else
        SetScrollPos(Handle, SB_CTL, FMax - FPosition, True);
    Change;
  end;


  if HandleAllocated then
    TWSScrollBarClass(WidgetSetClass).SetParams(Self);
end;

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

procedure TCustomScrollBar.SetPosition(Value: Integer);
begin
  SetParams(Value, FMin, FMax, FPageSize);
end;

procedure TCustomScrollBar.SetPageSize(Value: Integer);
begin
  SetParams(FPosition, FMin, FMax, Value);
end;

procedure TCustomScrollBar.SetMin(Value: Integer);
begin
  SetParams(FPosition, Value, FMax, FPageSize);
end;

procedure TCustomScrollBar.SetMax(Value: Integer);
begin
  SetParams(FPosition, FMin, Value, FPageSize);
end;

procedure TCustomScrollBar.Change;
begin
  inherited Changed;
  if Assigned(FOnChange) then FOnChange(Self);
end;

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

procedure TCustomScrollBar.DoScroll(var Message: TLMScroll);
var
  ScrollPos: Integer;
  ScrollCode: TScrollCode;
  NewPos: Longint;
begin
  NewPos := FPosition;
  case Message.ScrollCode of
    SB_LINEUP: begin
      ScrollCode := scLineUp;
      Dec(NewPos, FSmallChange * FRTLFactor);
    end;
    SB_LINEDOWN: begin
      ScrollCode := scLineDown;
      Inc(NewPos, FSmallChange * FRTLFactor);
    end;
    SB_PAGEUP: begin
      ScrollCode := scPageUp;
      Dec(NewPos, FLargeChange * FRTLFactor);
    end;
    SB_PAGEDOWN: begin
      ScrollCode := scPageDown;
      Inc(NewPos, FLargeChange * FRTLFactor);
    end;
    SB_THUMBPOSITION, SB_THUMBTRACK: begin
      if Message.ScrollCode = SB_THUMBPOSITION
      then ScrollCode := scPosition
      else ScrollCode := scTrack;
      { We need to reverse the positioning because SetPosition below
        calls SetParams that reverses the position. This acts as a
        double negative. }
      if NotRightToLeft
      then NewPos := Message.Pos
      else NewPos := FMax - Message.Pos;
    end;
    SB_TOP: begin
      ScrollCode := scTop;
      NewPos := FMin;
    end;
    SB_BOTTOM: begin
      ScrollCode := scBottom;
      NewPos := FMax;
    end;
    SB_ENDSCROLL: begin
      ScrollCode := scEndScroll;
    end;
  else
    Exit;
  end;

  if NewPos < FMin then NewPos := FMin;
  if NewPos > FMax then NewPos := FMax;
  ScrollPos := NewPos;
  Scroll(ScrollCode, ScrollPos);
  SetPosition(ScrollPos);
end;

procedure TCustomScrollBar.CNHScroll(var Message: TLMHScroll);
begin
  DoScroll(Message);
end;

procedure TCustomScrollBar.CNVScroll(var Message: TLMVScroll);
begin
  DoScroll(Message);
end;

procedure TCustomScrollBar.CNCtlColorScrollBar(var Message: TLMessage);
begin
//CallWIndowProc is not yet created so no code is here
end;

procedure TCustomScrollBar.WMEraseBkgnd(var Message: TLMEraseBkgnd);
begin
  DefaultHandler(Message);
end;

// included by stdctrls.pp