sscrollmax.pas

Alpha Controls.v5.46b Source

unit sScrollMax;
{$I sDefs.inc}
{.$DEFINE LOGGED}

interface

uses
  SysUtils, Classes, Windows, Messages, Graphics, Forms, ExtCtrls, Controls, Buttons,
  sPanel, sSpeedButton, sCommonData, ImgList{$IFDEF LOGGED}, sDebugMsgs{$ENDIF};

const
  CM_PARENTBEVELEDCHANGED = WM_USER + 1;
  CM_PARENTBUTTONVISIBLECHANGED = WM_USER + 3;

type
  TsScrollMax = class;
  TOnCanExpand = procedure(Sender: TObject; var CanExpand: Boolean) of object;
  TOnCanCollapse = procedure(Sender: TObject; var CanCollapse: Boolean) of object;

  TsScrollMaxBand = class(TCustomPanel)
  private
    FData: Pointer;
    FExpandedHeight: Integer;
    FButton: TsSpeedButton;
    FExpanded: Boolean;
    FOrder: Integer;
    FBeveled: Boolean;
    FBorderWidth: Integer;
    FParentBeveled: Boolean;
    FParentButtonFont: Boolean;
    FParentButtonVisible: Boolean;
    FOnExpand: TNotifyEvent;
    FOnCollapse: TNotifyEvent;
    FOnCanCollapse: TOnCanCollapse;
    FOnCanExpand: TOnCanExpand;
    FSkinData: TsCommonData;
    procedure ButtonClick(Sender: TObject);
    procedure SetExpanded(const Value: Boolean);
    procedure SetExpandedHeight(const Value: Integer);
    function GetOrder: Integer;
    procedure SetOrder(const Value: Integer);
    procedure SetParentBeveled(const Value: Boolean);
    procedure SetBeveled(const Value: Boolean);
    procedure SetBorderWidth(const Value: Integer);
    function IsBeveledStored: Boolean;
    function GetButtonVisible: Boolean;
    procedure SetButtonVisible(const Value: Boolean);
    function IsButtonVisibleStored: Boolean;
    procedure SetParentButtonVisible(const Value: Boolean);
    procedure CMParentBeveledChanged(var Msg: TMessage); message CM_PARENTBEVELEDCHANGED;
    procedure CMParentButtonVisibleChanged(var Msg: TMessage); message CM_PARENTBUTTONVISIBLECHANGED;
    procedure SetImageIndex(const Value: integer);
    procedure SetImages(const Value: TCustomImageList);
    function GetImageIndex: integer;
    function GetImages: TCustomImageList;
    function GetTitleHeight: integer;
    procedure SetTitleHeight(const Value: integer);
  protected
    procedure TextChanged;
    procedure BoundsChanged;
    procedure Paint; override;
    procedure SetParent(AParent: TWinControl); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure SetZOrder(TopMost: Boolean); override;
    function ScrollMax: TsScrollMax;
    procedure UpdateSize(ATop: Integer);
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    function CollapsedHeight: Integer;
    procedure ChangeScale(M, D : Integer); override;
  public
    procedure PrepareCache;
    procedure OurPaint(DC : HDC = 0; SendUpdated : boolean = True);
    procedure WndProc (var Message: TMessage); override;
    procedure PaintWindow(DC: HDC); override;
    procedure CreateWnd; override;

    procedure AfterConstruction; override;
    procedure Loaded; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Data: Pointer read FData write FData;
    property Button : TsSpeedButton read FButton;
  published
    property Expanded: Boolean read FExpanded write SetExpanded default True;
    property Caption;
    property ExpandedHeight: Integer read FExpandedHeight write SetExpandedHeight default 100;
    property Order: Integer read GetOrder write SetOrder stored False;
    property ButtonVisible: Boolean read GetButtonVisible write SetButtonVisible stored IsButtonVisibleStored;
    property Beveled: Boolean read FBeveled write SetBeveled default True;
    property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 0;
    property ImageIndex : integer read GetImageIndex write SetImageIndex default -1;
    property Images : TCustomImageList read GetImages write SetImages;
    property ParentBeveled: Boolean read FParentBeveled write SetParentBeveled stored IsBeveledStored;
    property ParentButtonVisible: Boolean read FParentButtonVisible write SetParentButtonVisible default True;
    property OnResize;
    property OnExpand: TNotifyEvent read FOnExpand write FOnExpand;
    property OnCollapse: TNotifyEvent read FOnCollapse write FOnCollapse;
    property OnCanExpand: TOnCanExpand read FOnCanExpand write FOnCanExpand;
    property OnCanCollapse: TOnCanCollapse read FOnCanCollapse write FOnCanCollapse;
    property Left stored False;
    property Top stored False;
    property Width;
    property Height;
    property Color;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property SkinData : TsCommonData read FSkinData write FSkinData;
    property TitleHeight : integer read GetTitleHeight write SetTitleHeight default 28;
    property Visible;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnStartDrag;
    property BiDiMode;
    property ParentBiDiMode;
  end;

  TsScrollMaxBands = class(TsPanel)
  private
    FScrolling: Boolean;
  protected
    procedure FocusChanged(Control: TWinControl);
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    procedure ScrollControls(const DeltaY: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    procedure WndProc (var Message: TMessage); override;
  end;

  TsPanelScrollBar = class(TsPanel)
  private
    FMin: Integer;
    FMax: Integer;
    FPos: Integer;
    FPage: Integer;
    Scroll: TsPanel;
    FDesignInteractive: Boolean;
    FInclusive: Boolean;
    FOnChange: TNotifyEvent;
    FOnScroll: TNotifyEvent;
    procedure SetParam(Index, Value: Integer);
    procedure SetInclusive(Value: Boolean);
  protected
    procedure CreateWnd; override;
    procedure SetTrackBar;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    procedure SetParams(const AMin, AMax, APage, APos: Integer);
    property Pos: Integer index 3 read FPos write SetParam;
    property DesignInteractive: Boolean read FDesignInteractive write FDesignInteractive;
    property Scroller: TsPanel read Scroll;
  published
    property Color;
    property Align;
    property Min: Integer index 0 read FMin write SetParam;
    property Max: Integer index 1 read FMax write SetParam;
    property Page: Integer index 2 read FPage write SetParam;
    property Position: Integer index 3 read FPos write SetParam;
    property Inclusive: Boolean read FInclusive write SetInclusive;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
  end;

  TsScrollMax = class(TsPanel)
  private
    FScrollBar: TsPanelScrollBar;
    FScrollPos: Integer;
    FY: Integer;
    FOnScroll: TNotifyEvent;
    FBeveled: Boolean;
    FButtonVisible: Boolean;
    FAutoHeight: Boolean;
    FExpandedHeight: Integer;
    FOneExpanded: Boolean;
    procedure Correct;
    procedure CorrectHeight;
    procedure BandMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure BandMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure BandMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure ScrollBarScroll(Sender: TObject);
    function GetBand(Index: Integer): TsScrollMaxBand;
    function GetBandCount: Integer;
    procedure SetScrollPos(const Value: Integer);
    procedure SetButtonVisible(const Value: Boolean);
    procedure SetBeveled(const Value: Boolean);
    procedure SetAutoHeight(const Value: Boolean);
    procedure SetExpandedHeight(const Value: Integer);
    function GetScrollBarWidth: Cardinal;
    procedure SetScrollBarWidth(const Value: Cardinal);
    function GetScrollBarVisible: Boolean;
    procedure SetScrollBarVisible(const Value: Boolean);
    procedure SetOneExpanded(const Value: Boolean);
  protected
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetChildParent: TComponent; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Resize; override;
  public
    FPnlEdit: TsScrollMaxBands;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure WndProc (var Message: TMessage); override;
    procedure ScrollInView(AControl: TControl);
    procedure MouseControls(AControls: array of TControl);
    procedure MouseClasses(AControlClasses: array of TControlClass);
    function AllCollapsed: Boolean;
    function AllExpanded: Boolean;
    procedure AddBand(Band: TsScrollMaxBand);
    property BandCount: Integer read GetBandCount;
    property Bands[Index: Integer]: TsScrollMaxBand read GetBand;
    property DockManager;
  published
    property ScrollPos: Integer read FScrollPos write SetScrollPos default 0;
    property BorderWidth default 3;
    property Beveled: Boolean read FBeveled write SetBeveled default True;
    property ButtonVisible: Boolean read FButtonVisible write SetButtonVisible default True;
    property AutoHeight: Boolean read FAutoHeight write SetAutoHeight;
    property ExpandedHeight: Integer read FExpandedHeight write SetExpandedHeight default -1;
    property ScrollBarWidth: Cardinal read GetScrollBarWidth write SetScrollBarWidth default 7;
    property ScrollBarVisible: Boolean read GetScrollBarVisible write SetScrollBarVisible default True;
    property OneExpanded: Boolean read FOneExpanded write SetOneExpanded default False;
    property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
    property Align default alLeft;
    property BevelInner;
    property BevelOuter default bvLowered;
    property BevelWidth;
    property BorderStyle;
    property Color;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnResize;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnStartDrag;
    property Anchors;
    property Constraints;
    property BiDiMode;
    property UseDockManager default True;
    property DockSite;
    property DragCursor;
    property DragKind;
    property ParentBiDiMode;
    property OnCanResize;
    property OnConstrainedResize;
    property OnDockDrop;
    property OnDockOver;
    property OnEndDock;
    property OnGetSiteInfo;
    property OnStartDock;
    property OnUnDock;
  end;

implementation

uses sSkinProps, sConst, acntUtils, sVCLUtils, sGraphUtils, sMessages, sAlphaGraph;

function PanelBorder(Panel: TCustomPanel): Integer;
begin
  Result := TPanel(Panel).BorderWidth;
  if TPanel(Panel).BevelOuter <> bvNone then Inc(Result, TPanel(Panel).BevelWidth);
  if TPanel(Panel).BevelInner <> bvNone then Inc(Result, TPanel(Panel).BevelWidth);
end;

type
  TsScroller = class(TsPanel)
  private
    FY: Integer;
    procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure TsScroller.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then FY := Y;
end;

procedure TsScroller.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Sm, T, OldPos: Integer;
begin
  if Shift = [ssLeft] then begin
    Sm := FY - Y;
    T := Top;
    if Sm <> 0 then begin
      with Parent as TsPanelScrollBar do begin
        OldPos := Pos;
        Pos := Pos - Round(Sm * (FMax - FMin + 1) / ClientHeight);
        if (Pos <> OldPos) and Assigned(FOnScroll) then FOnScroll(Parent);
      end;
    end;
    FY := Y - Top + T;
  end;
end;

procedure TsScroller.CMDesignHitTest(var Msg: TCMDesignHitTest);
begin
  with (Owner as TsPanelScrollBar) do Msg.Result := Integer(FDesignInteractive and (FPage <> FMax - FMin + 1));
end;

constructor TsPanelScrollBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SkinData.SkinSection := s_Gauge;
  BevelOuter := bvLowered;
  Color := clBtnShadow;
  Caption := '';
  ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];
  Scroll := TsScroller.Create(Self);
  Scroll.Parent := Self;
  Scroll.Caption := '';
  Scroll.ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];
  FMax := 100;
  FPage := 10;
  Width := 20;
  Height := 100;
end;

procedure TsPanelScrollBar.Loaded;
begin
  inherited Loaded;
  Resize;
end;

procedure TsPanelScrollBar.Resize;
begin
  inherited Resize;
  with Scroll do begin
    Top := BevelWidth;
    Left := BevelWidth;
    Width := Self.Width - 2 * BevelWidth;
  end;
  SetTrackBar;
end;

procedure TsPanelScrollBar.SetTrackBar;
var
  CH, H, T: Integer;
  L, FP, P, P1: Integer;
begin
  if FMin > FMax then FMin := FMax;
  if FPage > FMax - FMin + 1 then FPage := FMax - FMin + 1;
  if FInclusive then P := FPage else P := 0;
  P1 := FPage - P;
  if FPos > FMax - P then FPos := FMax - P;
  if FPos < FMin then FPos := FMin;
  L := FMax - FMin + 1;
  CH := Height - 2 * BevelWidth;
  H := Trunc(CH * FPage / L) + 1;
  FP := Trunc((FPos - FMin) / L * (L - P1)) + 1;
  T := Round(CH * FP / L);
  if H < 7 then H := 7;
  if H > CH then H := CH;
  if T < BevelWidth then T := BevelWidth;
  if T + H > Height - BevelWidth then T := Height - BevelWidth - H;
  if FPos = FMax - P then T := Height - BevelWidth - H;

  Scroll.SetBounds(Scroll.Left, T, Scroll.Width, H);
end;

procedure TsPanelScrollBar.SetParam(Index, Value: Integer);
begin
  case Index of
    0 : FMin := Value;
    1 : FMax := Value;
    2 : FPage := Value;
    3 : FPos := Value;
  end;
  SetParams(FMin, FMax, FPage, FPos);
end;

procedure TsPanelScrollBar.SetParams(const AMin, AMax, APage, APos: Integer);
begin
  FMin := AMin;
  FMax := AMax;
  FPage := APage;
  FPos := APos;
  if Assigned(FOnChange) then FOnChange(Self);
  SetTrackBar;
end;

procedure TsPanelScrollBar.SetInclusive(Value: Boolean);
begin
  FInclusive := Value;
  SetTrackBar;
end;

procedure TsPanelScrollBar.CreateWnd;
begin
  inherited CreateWnd;
  SetTrackBar;
end;

const
  SpeedSpacing = 4;

type
  TsBandBtn = class(TsSpeedButton)
  private
    procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;
    function CurrentState : integer; override;
    procedure Invalidate; override;
    procedure PrepareCache; override;
  protected
    procedure FontChanged;
  end;

procedure TsBandBtn.CMDesignHitTest(var Msg: TCMDesignHitTest);
begin
  Msg.Result := 1;
end;

function TsBandBtn.CurrentState: integer;
begin
  if (Parent <> nil) and TsScrollMaxBand(Parent).Expanded then Result := 1 else Result := inherited CurrentState
end;

procedure TsBandBtn.FontChanged;
begin
  if Parent <> nil then with Parent as TsScrollMaxBand do begin
    FParentButtonFont := False;
    Canvas.Font.Assign(Self.Font);
    Invalidate;
  end;
end;

constructor TsScrollMaxBand.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SkinData := TsCommonData.Create(Self, True);
  SkinData.COC := COC_TsPanel;
  ControlStyle := ControlStyle + [csSetCaption] - [csAcceptsControls];
  SkinData.SkinSection := s_BarPanel;
  BevelInner := bvNone;
  BevelOuter := bvNone;
  Height := 100;
  FExpandedHeight := 100;
//  ParentColor := True;
  FParentButtonFont := True;
  FParentButtonVisible := True;
  FParentBeveled := True;
  FButton := TsBandBtn.Create(Self);
  FButton.SkinData.SkinSection := s_BarTitle;
  with FButton as TsBandBtn do begin
    Alignment := taLeftJustify;
    SetDesigning(False);
    Parent := Self;
    Cursor := crArrow;
    OnClick := ButtonClick;
    Margin := 4;
    Spacing := SpeedSpacing;
    ParentColor := True;
    FButton.ParentBiDiMode := True;
  end;
  TitleHeight := 28;
  Expanded := True;
end;