fr_dock.pas

FASTREPORT报表工具,可以迅速制作报表.

  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;
    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;


{ TTBSeparator }

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

constructor TfrTBSeparator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Width := 8;
  Height := 8;
  FDrawBevel := True;
end;

procedure TfrTBSeparator.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 TfrTBSeparator.SetDrawBevel(Value: Boolean);
begin
  FDrawBevel := Value;
  Invalidate;
end;

procedure TfrTBSeparator.Paint;
begin
  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clBtnFace;
    Pen.Style := psClear;
    Rectangle(0, 0, Width, Height);
    Pen.Style := psSolid;
    if FDrawBevel then
    case Align of
      alLeft, alRight:
      begin
        Pen.Color := clBtnShadow;
        MoveTo(Width div 2 - 1, 2);
        LineTo(Width div 2 - 1, Height - 2);
        Pen.Color := clBtnHighlight;
        MoveTo(Width div 2, 2);
        LineTo(Width div 2, Height - 2);
      end;
      alTop, alBottom:
      begin
        Pen.Color := clBtnShadow;
        MoveTo(2, Height div 2 - 1);
        LineTo(Width - 2, Height div 2 - 1);
        Pen.Color := clBtnHighlight;
        MoveTo(2, Height div 2);
        LineTo(Width - 2, Height div 2);
      end;
    end;
    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;

constructor TfrTBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Width := 8;
  Height := 8;
end;

procedure TfrTBPanel.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 TfrTBPanel.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;

{ TTBButton }

constructor TfrTBButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Flat := True;
end;

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


{ TfrFloatWindow }

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.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WndParent := TForm(Owner).Handle;
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.FormDestroy(Sender: TObject);
begin
  if ToolBar <> nil then
    ToolBar.FWindow := nil;
end;


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

finalization
  DestroyToolbarList;
  FloatingToolBars.Free;

end.