fr_dock.pas

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

  inherited Destroy;
end;

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

procedure TfrToolBar.Paint;
var
  R: TRect;
begin
  with Canvas do
  begin
    Brush.Color := clBtnFace;
    R := Rect(0, 0, Width, Height);
    FillRect(R);
    if not IsFloat then
      Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
  end;
end;

function TfrToolBar.ParentAlign: TAlign;
begin
  Result := Parent.Align;
  if Result = alBottom then Result := alTop;
  if Result = alRight then Result := alLeft;
end;

function TfrToolBar.GetClientRect: TRect;
begin
  Result := inherited GetClientRect;
  InflateRect(Result, -1, -1);
end;

function TfrToolBar.GetVisible: Boolean;
begin
  if IsFloat then
    Result := FWindow.Visible else
    Result := Visible;
end;

procedure TfrToolBar.SetVisible(Value: Boolean);
begin
  if IsFloat then
    FWindow.Visible := Value else
    Visible := Value;
end;

procedure TfrToolBar.DockTo(Dock: TfrDock; X, Y: Integer);
var
  oldParent: TfrDock;
begin
  Hide;
  if FWindow <> nil then
  begin
    FWindow.Hide;
    FWindow.Release;
    Parent := nil;
  end;
  FWindow := nil;
  oldParent := nil;
  if (Parent <> nil) and (Parent is TfrDock) then
    oldParent := Parent as TfrDock;
  Parent := Dock;
  if oldParent <> nil then
    oldParent.AdjustBounds;
  FIsFloat := False;
  FDragBox.Show;
  RealignControls;
  Left := X; Top := Y;
  Show;
  Dock.AdjustBounds;
  RemoveFromToolbarList(Self);
end;

procedure TfrToolBar.AddToDock(Dock: TfrDock);
var
  X,Y: Integer;
begin
  X := 0; Y := 0;
  case Dock.Align of
    alTop:
      begin
        X := 0; Y := Dock.Height - 1;
      end;
    alBottom:
      begin
        X := 0; Y := -Height + 1;
      end;
    alLeft:
      begin
        X := Dock.Width - 1; Y := 0;
      end;
    alRight:
      begin
        X := -Width + 1; Y := 0;
      end;
  end;
  DockTo(Dock, X, Y);
end;

function TfrToolBar.FindDock(AOwner: TWinControl; p: TPoint): Boolean;
var
  i: Integer;
  c: TControl;
  d: TfrDock;
begin
  Result := False;
  for i := 0 to AOwner.ControlCount-1 do
  begin
    c := AOwner.Controls[i];
    if c is TfrDock then
      if (p.X >= c.Left) and (p.X <= c.Left + c.Width) and
         (p.Y >= c.Top) and (p.Y <= c.Top + c.Height) then
      begin
        with c as TfrDock do
          if ((FOrientation = toHorzOnly) and (Align in [alLeft, alRight])) or
             ((FOrientation = toVertOnly) and (Align in [alTop, alBottom])) then
            break;
        d := c as TfrDock;
        if d.Align in [alTop,alBottom] then
        begin
          p := Point(p.X - d.Left, d.Height - 1);
          if p.X + Width > d.Width then
            p.X := d.Width - Width;
          if p.X < 0 then p.X := 0;
          if d.Align = alBottom then
            p.Y := -Height + 1;
        end
        else
        begin
          p := Point(d.Width - 1, p.Y - d.Top);
          if p.Y + Height > d.Height then
            p.Y := d.Height - Height;
          if p.Y < 0 then p.Y := 0;
          if d.Align = alRight then
            p.X := -Height + 1;
        end;
        DockTo(d, p.X, p.Y);
        SetCaptureControl(Self);
        DoMouseDown(Self, mbLeft, [], 0, 0);
        Result := True;
        break;
      end;
  end;
end;

procedure TfrToolBar.RealignControls;
var
  i, j, t: Integer;
  TempCtrl: TControl;
  Ctrls: Array[0..100] of TControl;
begin
  for i := 0 to ControlCount-1 do
    Ctrls[i] := Controls[i];
  for i := 0 to ControlCount-1 do
    for j := 0 to ControlCount-2 do
      if Parent.Align in [alTop, alBottom, alNone] then
      begin
        if Ctrls[j].Left > Ctrls[j + 1].Left then
        begin
          TempCtrl := Ctrls[j + 1];
          Ctrls[j + 1] := Ctrls[j];
          Ctrls[j] := TempCtrl;
        end;
      end
      else
      begin
        if (Ctrls[j].Align in [alTop, alBottom]) and
           (Ctrls[j + 1].Align in [alTop, alBottom]) and
           (Ctrls[j].Top > Ctrls[j + 1].Top) then
        begin
          TempCtrl := Ctrls[j];
          Ctrls[j] := Ctrls[j + 1];
          Ctrls[j + 1] := TempCtrl;
        end;
      end;
  case Parent.Align of
    alTop, alBottom, alNone:
    begin
      if Height > Width then
      begin
        t := Width;
        Width := Height;
        Height := t;
      end;
      for t := 0 to ControlCount-1 do
        if Ctrls[t] <> nil then
          if not (Ctrls[t].Align in [alLeft, alRight]) then
            if (Ctrls[t].Align = alBottom) then
              Ctrls[t].Align := alRight
            else
            begin
              Ctrls[t].Left := Ctrls[t].Top;
              Ctrls[t].Align := alLeft;
            end;
    end;
    alLeft, alRight:
    begin
      if Width > Height then
      begin
        t := Width;
        Width := Height;
        Height := t;
      end;
      for t := 0 to ControlCount-1 do
        if Ctrls[t] <> nil then
          if not (Ctrls[t].Align in [alTop, alBottom]) then
            if (Ctrls[t].Align = alRight) then
              Ctrls[t].Align := alBottom
            else
            begin
              Ctrls[t].Top := Ctrls[t].Left;
              Ctrls[t].Align := alTop;
            end;
    end;
  end;
end;

procedure TfrToolBar.AdjustBounds;
var
  i, max: Integer;
  c: TControl;
begin
  RealignControls;
  max := 0;
  for i := 0 to ControlCount-1 do
  begin
    c := Controls[i];
    if Parent.Align in [alTop, alBottom, alNone] then
      Inc(max, c.Width)
    else
      Inc(max, c.Height);
  end;
  if Parent.Align in [alTop, alBottom, alNone] then
    Width := max + 4 else
    Height := max + 4;
end;

procedure TfrToolBar.MakeFloat;
var
  p: TPoint;
begin
  FIsFloat := True;
  GetCursorPos(p);
  FloatTo(p.X, p.Y);
  FWindow.Capture;
end;

procedure TfrToolBar.FloatTo(X, Y: Integer);
var
  oldParent: TfrDock;
begin
  FIsFloat := True;
  if FWindow = nil then
  begin
    oldParent := nil;
    if (Parent <> nil) and (Parent is TfrDock) then
      oldParent := Parent as TfrDock;
    Hide;
    FDragBox.Hide;
    FWindow := TfrFloatWindow.Create(GetParentForm(Self));
    FWindow.BorderStyle := bsToolWindow;
    FWindow.Left := X;
    FWindow.Top := Y;
    FWindow.Caption := Caption;
    FWindow.FormStyle := fsStayOnTop;
    Parent := FWindow;
    RealignControls;
    if oldParent <> nil then
      oldParent.AdjustBounds;
    FWindow.ClientWidth := Width - 11;
    FWindow.ClientHeight := Height;
    FWindow.ToolBar := Self;
    Left := 0; Top := 0;
    Show;
    AddToToolbarList(Self);
  end
  else
    FWindow.SetBounds(X, Y, FWindow.Width, FWindow.Height);
end;

function TfrToolBar.MoveTo(X, Y: Integer): Boolean;
var
  i, n, oldSize, ShiftCount: Integer;
  c: TControl;
  procedure Shift(ax,ay:Integer);
  begin
    x := ax;
    y := ay;
    Inc(ShiftCount);
  end;
begin
  Result := True;
  if IsFloat then Exit;
  n := 0;
  repeat
    ShiftCount := 0;
    if ParentAlign = alTop then
    begin
      if x < -20 then FIsFloat := True;
      if x < 0 then Shift(0, y);
      if x + Width > Parent.Width then Shift(Parent.Width - Width, y);
    end
    else // if ParentAlign = alLeft then
    begin
      if y < -20 then FIsFloat := True;
      if y < 0 then Shift(x, 0);
      if y + Height > Parent.Height then Shift(x, Parent.Height - Height);
    end;
    if not IsFloat then
      for i := 0 to Parent.ControlCount-1 do
      begin
        c := Parent.Controls[i];
        if (c <> Self) and c.Visible then
          if ParentAlign = alTop then
          begin
            if ((y >= c.Top) and (y < c.Top + c.Height)) or
               ((y <= c.Top) and (y + Height > c.Top)) then
            begin
              if (x >= c.Left) and (x < c.Left + c.Width) then
                Shift(c.Left + c.Width, y);
              if (x < c.Left) and (x + Width > c.Left) then
                Shift(c.Left - Width, y);
            end;
          end
          else // if ParentAlign = alLeft then
          begin
            if ((x >= c.Left) and (x < c.Left + c.Width)) or
               ((x <= c.Left) and (x + Width > c.Left)) then
            begin
              if (y >= c.Top) and (y < c.Top + c.Height) then
                Shift(x, c.Top + c.Height);
              if (y < c.Top) and (y + Height > c.Top) then
                Shift(x, c.Top - Height);
            end;
          end;
      end;
    Inc(n);
  until (n > 3) or (ShiftCount = 0) or IsFloat;

  if not FCanFloat then FIsFloat := False;
  if IsFloat then
    MakeFloat
  else
    if n < 3 then
    begin
      if ParentAlign = alTop then
        if (y + Height > Parent.Height) or (y < 0) then
          oldSize := Parent.Height else
          oldSize := 0
      else
        if (x + Width > Parent.Width) or (x < 0) then
          oldSize := Parent.Width else
          oldSize := 0;
      Left := x;
      Top := y;
      (Parent as TfrDock).AdjustBounds;
      if FCanFloat then
        if ((ParentAlign = alTop) and (Parent.Height = oldSize)) or
           ((ParentAlign = alLeft) and (Parent.Width = oldSize)) then
          MakeFloat;
    end
    else Result := False;
end;

procedure TfrToolBar.DoMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  p: TPoint;
begin
  GetCursorPos(p);
  FLastX := p.X; FLastY := p.Y;
  FDown := True;
end;

procedure TfrToolBar.DoMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  p: TPoint;
  dx, dy: Integer;
  StepX, StepY: Integer;
  b: Boolean;
begin
  if IsFloat then
  begin
    Cursor := crDefault;
    FDown := False;
    Exit;
  end;
  if not FDown then Exit;
  GetCursorPos(p);
  if ParentAlign = alTop then
    StepY := (Parent as TfrDock).RowSize else
    StepY := 1;
  if ParentAlign = alLeft then
    StepX := (Parent as TfrDock).RowSize else
    StepX := 1;
  dx := (p.X - FLastX) div StepX * StepX;
  dy := (p.Y - FLastY) div StepY * StepY;
  b := False;
  if (dx <> 0) or (dy <> 0) then b := MoveTo(Left + dx, Top + dy);
  if b then
  begin
    if dx <> 0 then FLastX := p.X;
    if dy <> 0 then FLastY := p.Y;
  end;
end;

procedure TfrToolBar.DoMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDown := False;
end;

procedure TfrToolBar.DoResize(Sender: TObject);
begin
  if csDestroying in ComponentState then Exit;
  FDragBox.SetBounds(0, 0, 11, 11);
  if ParentAlign = alTop then
    FDragBox.Align := alLeft else
    FDragBox.Align := alTop;
end;

procedure TfrToolBar.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  if csDesigning in ComponentState then
    inherited else
    DefaultHandler(Message);
end;

function TfrToolBar.GetFloatWindow: TForm;
begin
  Result := FWindow;
end;


{----------------------------------------------------------------------------}
procedure DrawFrameRect(R: TRect);
var
  DC: HDC;
  i: Integer;
begin
  DC := GetDC(0);
  for i := 0 to 3 do
  begin
    DrawFocusRect(DC, R);
    InflateRect(R, -1, -1);
  end;
  ReleaseDC(0, DC);
end;

procedure TfrFloatWindow.Capture;
begin
  SetCaptureControl(Self);
  MouseDown(mbLeft, [], 0, 0);
end;

procedure TfrFloatWindow.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  if Msg.Result = htCaption then Msg.Result := htClient;
end;

procedure TfrFloatWindow.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  p: TPoint;
begin
  GetCursorPos(p);
  FRect := Rect(p.X, p.Y, p.X + Width, p.Y + Height);
  Application.ProcessMessages;
  DrawFrameRect(FRect);
  FDown := True;
end;

procedure TfrFloatWindow.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  p: TPoint;
begin
  if not FDown then Exit;
  GetCursorPos(p);
  DrawFrameRect(FRect);
  FRect := Rect(p.X, p.Y, p.X + Width, p.Y + Height);
  if ToolBar.FindDock(Owner as TWinControl,
    (Owner as TWinControl).ScreenToClient(Point(p.X, p.Y))) then
    Exit;
  DrawFrameRect(FRect);
end;

procedure TfrFloatWindow.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  DrawFrameRect(FRect);
  MoveWindow(Handle, FRect.Left, FRect.Top, Width, Height, True);
  Show;
  FDown := False;
end;

procedure TfrFloatWindow.FormShow(Sender: TObject);
begin
  SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
    SWP_NOSIZE or SWP_NOACTIVATE);
end;

procedure TfrFloatWindow.FormDestroy(Sender: TObject);
begin
  if ToolBar <> nil then
    ToolBar.FWindow := nil;
end;


{----------------------------------------------------------------------------}
initialization
  FloatingToolBars := TList.Create;
  RegRootKey := 'Software\FastReport';

finalization
  DestroyToolbarList;
  FloatingToolBars.Free;

end.