frxdock.pas

报表控件。FastReport 是非常强大的报表控件

  begin
    oldParent := nil;
    if (Parent <> nil) and (Parent is TfrxDock) then
      oldParent := Parent as TfrxDock;
    Hide;
    FDragBox.Hide;
    FWindow := TfrxFloatWindow.Create(GetParentForm(Self));
    FWindow.BorderStyle := bsNone;
    FWindow.Left := X;
    FWindow.Top := Y;
    FWindow.Caption := Caption;
    Parent := FWindow;
    RealignControls;
    AdjustBounds;
    if oldParent <> nil then
      oldParent.AdjustBounds;
    FWindow.ClientWidth := Width + 6;
    FWindow.ClientHeight := Height + 21;
    FWindow.ToolBar := Self;
    Left := 3; Top := 18;
    Show;
    FWindow.Show;
    AddToToolbarList(Self);
  end
  else
    FWindow.SetBounds(X, Y, FWindow.Width, FWindow.Height);
end;

function TfrxToolBar.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 TfrxDock).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 TfrxToolBar.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 TfrxToolBar.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 TfrxDock).RowSize else
    StepY := 1;
  if ParentAlign = alLeft then
    StepX := (Parent as TfrxDock).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 TfrxToolBar.DoMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDown := False;
end;

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

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

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


{ TfrxTBPanel }

function GetAlign(al: TAlign): TAlign;
begin
  if al in [alLeft, alRight] then
    Result := alTop else
    Result := alLeft;
end;

constructor TfrxTBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Width := 8;
  Height := 8;
  BevelInner := bvNone;
  BevelOuter := bvNone;
end;

procedure TfrxTBPanel.SetParent(AParent:TWinControl);
begin
  inherited;
  if not (csDestroying in ComponentState) and (AParent <> nil) and (Parent is TPanel) then
    Align := GetAlign(AParent.Parent.Align);
end;

procedure TfrxTBPanel.Paint;
begin
  with Canvas do
  begin
    Brush.Color := clBtnFace;
    FillRect(Rect(0, 0, Width, Height));
    if csDesigning in ComponentState then
    begin
      Brush.Style := bsClear;
      Pen.Style := psDot;
      Pen.Color := clBtnShadow;
      Rectangle(0, 0, Width - 1, Height - 1);
    end;
  end;
end;


{ TfrxFloatWindow }

constructor TfrxFloatWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

procedure TfrxFloatWindow.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WndParent := TForm(Owner).Handle;
end;

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

procedure TfrxFloatWindow.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  p: TPoint;
begin
  GetCursorPos(p);
  FPoint := p;
  Application.ProcessMessages;
  FDown := True;
end;

procedure TfrxFloatWindow.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  p: TPoint;
begin
  if not FDown or not (ssLeft in Shift) then Exit;
  GetCursorPos(p);
  SetBounds(Left + p.X - FPoint.X, Top + p.Y - FPoint.Y, Width, Height);

  FPoint := p;
  if ToolBar.FindDock(Owner as TWinControl,
    (Owner as TWinControl).ScreenToClient(p)) then
    Exit;
end;

procedure TfrxFloatWindow.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FDown := False;
end;

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

procedure TfrxFloatWindow.FormPaint(Sender: TObject);
begin
  with Canvas do
  begin
    Pen.Color := clGray;
    Pen.Width := 3;
    Rectangle(1, 1, Width - 1, Height - 1);

    Brush.Color := clGray;
    FillRect(Rect(3, 3, Width - 3, 18));

    Pen.Width := 1;
    Pen.Color := clBtnFace;
    MoveTo(2, 3); LineTo(2, Height - 3);
    MoveTo(3, 2); LineTo(Width - 3, 2);
    MoveTo(Width - 3, 3); LineTo(Width - 3, Height - 3);
    MoveTo(3, Height - 3); LineTo(Width - 3, Height - 3);

    Font.Color := clCaptionText;
    Font.Style := [fsBold];
    TextOut(6, 3, Caption);
  end;
end;

procedure TfrxFloatWindow.CloseBtnClick(Sender: TObject);
begin
  Close;
end;

procedure TfrxFloatWindow.FormShow(Sender: TObject);
begin
  CloseBtn.SetBounds(Width - 14, 4, 11, 11);
end;


{ TfrxDockSite }

type
  THackControl = class(TControl)
  end;

constructor TfrxDockSite.Create(AOwner: TComponent);
begin
  inherited;
  DockSite := True;
  Align := alLeft;
  Caption := ' ';
  AutoSize := True;
  BevelInner := bvNone;
  BevelOuter := bvNone;
  Width := 10;

  FSplitter := TGraphicControl.Create(Self);
  with FSplitter do
  begin
    Cursor := crHSplit;
    Visible := False;
    Width := 3;
  end;
  THackControl(FSplitter).OnMouseDown := SMouseDown;
  THackControl(FSplitter).OnMouseMove := SMouseMove;
  THackControl(FSplitter).OnMouseUp := SMouseUp;
end;

procedure TfrxDockSite.SetParent(AParent: TWinControl);
begin
  inherited;
  if Parent <> nil then
    FSplitter.Parent := Parent;
end;

procedure TfrxDockSite.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited;
  if FSplitter <> nil then
    if Align <> FSplitter.Align then
    begin
      if Align = alLeft then
        FSplitter.Left := Left + Width + 3 else
        FSplitter.Left := Left - 3;
      FSplitter.Align := Align;
    end;
end;

procedure TfrxDockSite.DockDrop(Source: TDragDockObject; X, Y: Integer);
begin
  inherited;
  if Width < FPanelWidth then
    Source.Control.Width := FPanelWidth;
  FSplitter.Show;
end;

procedure TfrxDockSite.DockOver(Source: TDragDockObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  inherited;
  FPanelWidth := Source.Control.Width;
end;

function TfrxDockSite.DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean;
begin
  Result := inherited DoUnDock(NewTarget, Client);
  if DockClientCount <= 1 then
    FSplitter.Hide;
end;

procedure TfrxDockSite.SMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDown := True;
end;

procedure TfrxDockSite.SMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FDown then
  begin
    AutoSize := False;
    if Align = alLeft then
      Width := Width + X else
      Width := Width - X;
    AutoSize := True;
  end;
end;

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

procedure TfrxDockSite.ReloadDockedControl(const AControlName: string;
  var AControl: TControl);
begin
  AControl := FindGlobalComponent(AControlName) as TControl;
end;



{----------------------------------------------------------------------------}

initialization
  FloatingToolBars := TList.Create;
  frxRegRootKey := 'Software\Fast Reports';

finalization
  DestroyToolbarList;
  FloatingToolBars.Free;

end.


//<censored>