fr_dock.pas

FreeReport 2.34 consists of the report engine, designer and previewer, with capabilities comparable

{*****************************************}
{                                         }
{             FastReport v2.3             }
{              Tool controls              }
{                                         }
{  Copyright (c) 1998-99 by Tzyganenko A. }
{                                         }
{*****************************************}

unit FR_Dock;

interface

{$I FR.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, FR_Ctrls;

type
  TfrOrientation = (toAny, toVertOnly, toHorzOnly);

  TfrFloatWindow = class;

  TfrDock = class(TPanel)
  private
    FRowSize: Integer;
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure AdjustBounds;
    procedure Paint; override;
  published
    property RowSize: Integer read FRowSize write FRowSize default 26;
  end;

  TfrDragBox = class(TGraphicControl)
  protected
    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;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
  end;

  TfrToolBar = class(TPanel)
  private
    FDragBox: TfrDragBox;
    FWindow: TfrFloatWindow;
    FIsFloat: Boolean;
    FDown: Boolean;
    FLastX, FLastY: Integer;
    FOrientation: TfrOrientation;
    FCanFloat: Boolean;
    function ParentAlign: TAlign;
    function FindDock(AOwner: TWinControl; p: TPoint): Boolean;
    procedure MakeFloat;
    function MoveTo(X, Y: Integer): Boolean;
    function GetVisible: Boolean;
    procedure SetVisible(Value: Boolean);
    procedure DockTo(Dock: TfrDock; X, Y: Integer);
    procedure FloatTo(X,Y: Integer);
    procedure DoMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure DoMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure DoResize(Sender: TObject);
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    function GetFloatWindow: TForm;
  protected
    procedure Loaded; override;
    procedure RealignControls;
    function GetClientRect: TRect; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure AdjustBounds;
    procedure AddToDock(Dock: TfrDock);
    property IsFloat: Boolean read FIsFloat;
    property FloatWindow: TForm read GetFloatWindow;
    property IsVisible: Boolean read GetVisible write SetVisible;
  published
    property CanFloat: Boolean read FCanFloat write FCanFloat default True;
    property Orientation: TfrOrientation read FOrientation write FOrientation;
  end;

  TfrFloatWindow = class(TForm)
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FRect: TRect;
    FDown: Boolean;
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
  protected
    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;
  public
    ToolBar: TfrToolBar;
    procedure Capture;
  end;

var
  RegRootKey: String;

const
  rsToolBar             = 'ToolBar\';
  rsForm                = 'Form\';
  rsWidth               = 'Width';
  rsHeight              = 'Height';
  rsTop                 = 'Top';
  rsLeft                = 'Left';
  rsFloat               = 'isFloat';
  rsVisible             = 'isVisible';
  rsX                   = 'XPosition';
  rsY                   = 'YPosition';
  rsDockName            = 'DockName';

procedure SaveToolbarPosition(t: TfrToolBar);
procedure RestoreToolbarPosition(t: TfrToolBar);
procedure SaveFormPosition(f: TForm);
procedure RestoreFormPosition(f: TForm);


implementation

{$R *.DFM}

uses Registry;

var
  FloatingToolBars: TList;


procedure AddToToolbarList(t: TfrToolBar);
begin
  if FloatingToolbars.IndexOf(t) <> -1 then
    FloatingToolbars.Add(t);
end;

procedure RemoveFromToolbarList(t: TfrToolBar);
var
  i: Integer;
begin
  i := FloatingToolbars.IndexOf(t);
  if i <> -1 then
    FloatingToolbars.Delete(i);
end;

procedure DestroyToolbarList;
var
  i: Integer;
begin
  for i := 0 to FloatingToolBars.Count-1 do
    TfrToolBar(FloatingToolBars[i]).Free;
end;


procedure SaveToolbarPosition(t: TfrToolBar);
var
  Ini: TRegIniFile;
  X, Y: integer;
  Name: String;
begin
  Ini := TRegIniFile.Create(RegRootKey);
  Name := rsToolbar + t.Name;
  Ini.WriteBool(Name, rsFloat, t.isFloat);
  Ini.WriteBool(Name, rsVisible, t.IsVisible);
  X := t.Left; Y := t.Top;
  if t.IsFloat then
  begin
    X := t.FloatWindow.Left; Y := t.FloatWindow.Top;
  end;
  Ini.WriteInteger(Name, rsX, X);
  Ini.WriteInteger(Name, rsY, Y);
  Ini.WriteInteger(Name, rsWidth, t.Width);
  Ini.WriteInteger(Name, rsHeight, t.Height);
  if t.Parent is TfrDock then
    Ini.WriteString(Name, rsDockName, t.Parent.Name);
  Ini.Free;
end;

procedure RestoreToolbarPosition(t: TfrToolBar);
var
  Ini: TRegIniFile;
  X, Y: Integer;
  DN: string;
  NewDock: TfrDock;
  Name: String;
begin
  Ini := TRegIniFile.Create(RegRootKey);
  Name := rsToolbar + t.Name;
  t.IsVisible := False;
  X := Ini.ReadInteger(Name, rsX, t.Left);
  Y := Ini.ReadInteger(Name, rsY, t.Top);
  t.Width := Ini.ReadInteger(Name, rsWidth, t.Width);
  t.Height := Ini.ReadInteger(Name, rsHeight, t.Height);
  if Ini.ReadBool(Name, rsFloat, False) then
    t.FloatTo(X, Y)
  else
  begin
    t.Left := X;
    t.Top := Y;
    DN := Ini.ReadString(Name, rsDockName, t.Parent.Name);
    if (t.Owner <> nil) then
    begin
      NewDock := t.Owner.FindComponent(DN) as TfrDock;
      if (NewDock <> nil) and (NewDock <> t.Parent) then
        t.DockTo(NewDock, X, Y);
    end;
    t.AdjustBounds;
  end;
  t.IsVisible := Ini.ReadBool(Name, rsVisible, True);
  Ini.Free;
end;

procedure SaveFormPosition(f: TForm);
var
  Ini: TRegIniFile;
  Name: String;
begin
  Ini := TRegIniFile.Create(RegRootKey);
  Name := rsForm + f.Name;
  Ini.WriteBool(Name, rsVisible, f.Visible);
  Ini.WriteInteger(Name, rsX, f.Left);
  Ini.WriteInteger(Name, rsY, f.Top);
  Ini.WriteInteger(Name, rsWidth, f.Width);
  Ini.WriteInteger(Name, rsHeight, f.Height);
  Ini.Free;
end;

procedure RestoreFormPosition(f: TForm);
var
  Ini: TRegIniFile;
  Name: String;
begin
  Ini := TRegIniFile.Create(RegRootKey);
  Name := rsForm + f.Name;
  f.Hide;
  f.Left := Ini.ReadInteger(Name, rsX, f.Left);
  f.Top := Ini.ReadInteger(Name, rsY, f.Top);
  f.Width := Ini.ReadInteger(Name, rsWidth, f.Width);
  f.Height := Ini.ReadInteger(Name, rsHeight, f.Height);
  if Ini.ReadBool(Name, rsVisible, True) then
    f.Show;
  Ini.Free;
end;


{--------------------------------------------------------------------------}
constructor TfrDock.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  RowSize := 26;
end;

procedure TfrDock.Loaded;
begin
  inherited Loaded;
  AdjustBounds;
end;

procedure TfrDock.AdjustBounds;
var
  i, Line, LineCount, l, dl: Integer;
  CtlOnLine, NewSize: Integer;
  c: TControl;
  ShiftNeeded: Boolean;
begin
  if ControlCount = 0 then
  begin
    if Align in [alTop, alBottom] then
      Height := 1 else
      Width := 1;
    Exit;
  end;
  if Align in [alTop, alBottom] then
    L := Height else
    L := Width;
  LineCount := L div RowSize;
  NewSize := RowSize * LineCount + 1;
  L := 0;
  dL := RowSize;
  if Align in [alRight, alBottom] then
  begin
    dL := -RowSize;
    if Align = alRight then
      L := Width else
      L := Height;
  end;
  Line := 0;
  while Line < LineCount do
  begin
    CtlOnLine := 0;
    for i := 0 to ControlCount-1 do
    begin
      c := Controls[i];
      if c.Visible then
      case Align of
        alLeft:
          if (c.Left = L) or
            ((c.Left < L) and (c.Left + c.Width > L)) then Inc(CtlOnLine);
        alRight:
          if (c.Left + c.Width = L) or
            ((c.Left + c.Width > L) and (c.Left < L)) then Inc(CtlOnLine);
        alTop:
          if (c.Top = L) or
            ((c.Top < L) and (c.Top + c.Height > L)) then Inc(CtlOnLine);
        alBottom:
          if (c.Top + c.Height = L) or
            ((c.Top + c.Height > L) and (c.Top < L)) then Inc(CtlOnLine);
      end;
    end;
    if CtlOnLine = 0 then
    begin
      for i := 0 to ControlCount-1 do
      begin
        c := Controls[i];
        if c.Visible then
        begin
          if ((Align = alLeft) and (c.Left > L)) or
             ((Align = alRight) and (c.Left + c.Width > L)) then
            c.Left := c.Left - RowSize;
          if ((Align = alTop) and (c.Top > L)) or
             ((Align = alBottom) and (c.Top + c.Height > L)) then
            c.Top := c.Top - RowSize;
        end;
      end;
      Dec(NewSize, RowSize);
      Dec(LineCount);
      Dec(Line);
      if Align in [alTop, alLeft] then Dec(L, dL);
    end;
    Inc(Line);
    Inc(L, dL);
  end;

  ShiftNeeded := False;
  for i := 0 to ControlCount-1 do
  begin
    c := Controls[i];
    if c.Visible then
    begin
      if (Align = alRight) and (c.Left < 0) then
      begin
        ShiftNeeded := True;
        L := -c.Left + 1;
        Inc(NewSize, L);
        break;
      end;
      if (Align = alBottom) and (c.Top < 0) then
      begin
        ShiftNeeded := True;
        L := -c.Top + 1;
        Inc(NewSize, L);
        break;
      end;
      if (Align = alTop) and (c.Top + c.Height > NewSize) then
      begin
        NewSize := c.Top + c.Height + 1;
        break;
      end;
      if (Align = alLeft) and (c.Left + c.Width > NewSize) then
      begin
        NewSize := c.Left + c.Width + 1;
        break;
      end;
    end;
  end;
  if ShiftNeeded then
    for i := 0 to ControlCount-1 do
    begin
      c := Controls[i];
      if c.Visible then
        if Align = alRight then
          c.Left := c.Left + L
        else if Align = alBottom then
          c.Top := c.Top + L;
    end;

  for i := 0 to ControlCount-1 do
  begin
    c := Controls[i];
    if c.Visible then
    begin
      if (Align = alRight) and (c.Left + c.Width > NewSize) then
        NewSize := c.Left + c.Width;
      if (Align = alBottom) and (c.Top + c.Height > NewSize) then
        NewSize := c.Top + c.Height;
    end;
  end;

  case Align of
    alTop: Height := NewSize;
    alLeft: Width := NewSize;
    alBottom:
      if Height < NewSize then
        SetBounds(0, Top - (NewSize - Height), Width, NewSize)
      else
        Height := NewSize;
    alRight:
      if Width < NewSize then
        SetBounds(Left - (NewSize - Width), Top, NewSize, Height)
      else
        Width := NewSize;
  end;
end;

procedure TfrDock.Paint;
var
  R: TRect;
begin
  with Canvas do
  begin
    Brush.Color := clBtnFace;
    R := Rect(0, 0, Width, Height);
    FillRect(R);
    if csDesigning in ComponentState then
    begin
      Pen.Color := clBtnShadow;
      Rectangle(0, 0, Width, Height);
    end;
  end;
end;


{--------------------------------------------------------------------------}
constructor TfrDragBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 11;
  Height := 11;
end;

procedure TfrDragBox.Paint;
var
  R: TRect;
begin
  with Canvas do
  begin
    Brush.Color := clBtnFace;
    R := Rect(0, 0, Width, Height);
    FillRect(R);
  end;
  if (Parent as TfrToolBar).ParentAlign = alTop then
  begin
    R := Rect(2, 0, 5, Height);
    Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
    R := Rect(5, 0, 8, Height);
    Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
  end
  else if (Parent as TfrToolBar).ParentAlign = alLeft then
  begin
    R := Rect(0, 2, Width, 5);
    Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
    R := Rect(0, 5, Width, 8);
    Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
  end;
end;

procedure TfrDragBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  p: TPoint;
begin
  p := ClientToScreen(Point(X, Y));
  p := Parent.ScreenToClient(p);
  (Parent as TfrToolBar).DoMouseDown(Self, Button, Shift, P.X, P.Y);
end;

procedure TfrDragBox.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  p: TPoint;
begin
  p := ClientToScreen(Point(X, Y));
  p := Parent.ScreenToClient(p);
  (Parent as TfrToolBar).DoMouseMove(Self, Shift, P.X, P.Y);
end;

procedure TfrDragBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  p: TPoint;
begin
  p := ClientToScreen(Point(X, Y));
  p := Parent.ScreenToClient(p);
  (Parent as TfrToolBar).DoMouseUp(Self, Button, Shift, P.X, P.Y);
end;


{--------------------------------------------------------------------------}
constructor TfrToolBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height := 26;
  FDragBox := TfrDragBox.Create(Self);
  FDragBox.Parent := Self;
  FDragBox.Align := alLeft;
  FullRepaint := False;
  OnMouseDown := DoMouseDown;
  OnMouseMove := DoMouseMove;
  OnMouseUp := DoMouseUp;
  OnResize := DoResize;
  FCanFloat := True;
  FOrientation := toAny;
end;

destructor TfrToolBar.Destroy;
begin
  FDragBox.Free;
  if FWindow <> nil then
  begin
    Parent := nil;
    FWindow.Hide;
    FWindow.Free;
  end;