frxdesgnworkspace1.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{           Designer workspace             }
{                                          }
{         Copyright (c) 1998-2008          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxDesgnWorkspace1;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, Buttons, frxClass, frxDesgn,
  frxDesgnWorkspace, frxPopupForm
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TfrxDesignTool = (dtSelect, dtHand, dtZoom, dtText, dtFormat);

  TfrxGuideItem = class(TCollectionItem)
  public
    Left, Top, Right, Bottom: Extended;
  end;

  TfrxVirtualGuides = class(TCollection)
  private
    function GetGuides(Index: Integer): TfrxGuideItem;
  public
    constructor Create;
    procedure Add(Left, Top, Right, Bottom: Extended);
    property Items[Index: Integer]: TfrxGuideItem read GetGuides; default;
  end;

  TDesignerWorkspace = class(TfrxDesignerWorkspace)
  private
    FDesigner: TfrxDesignerForm;
    FGuide: Integer;
    FListBox: TListBox;
    FMemo: TfrxMemoView;
    FPopupForm: TfrxPopupForm;
    FPopupFormVisible: Boolean;
    FShowGuides: Boolean;
    FSimulateMove: Boolean;
    FTool: TfrxDesignTool;
    FVirtualGuides: TfrxVirtualGuides;
    FVirtualGuideObjects: TList;
    procedure DoLBClick(Sender: TObject);
    procedure DoPopupHide(Sender: TObject);
    procedure CreateVirtualGuides;
    procedure LBDrawItem(Control: TWinControl; Index: Integer;
      ARect: TRect; State: TOwnerDrawState);
    procedure SetShowGuides(const Value: Boolean);
    procedure SetHGuides(const Value: TStrings);
    procedure SetVGuides(const Value: TStrings);
    function GetHGuides: TStrings;
    function GetVGuides: TStrings;
    property HGuides: TStrings read GetHGuides write SetHGuides;
    property VGuides: TStrings read GetVGuides write SetVGuides;
    procedure SetTool(const Value: TfrxDesignTool);
  protected
    procedure CheckGuides(var kx, ky: Extended; var Result: Boolean); override;
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean); override;
    procedure DrawObjects; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); 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 DblClick; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DeleteObjects; override;
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    procedure SimulateMove;
    procedure SetInsertion(AClass: TfrxComponentClass;
      AWidth, AHeight: Extended; AFlag: Word); override;
    property ShowGuides: Boolean read FShowGuides write SetShowGuides;
    property Tool: TfrxDesignTool read FTool write SetTool;
  end;

implementation

uses
  ComCtrls, frxDesgnCtrls, frxUtils, frxDataTree, frxDMPClass, frxRes;

type
  THackMemo = class(TfrxCustomMemoView);

function Round8(e: Extended): Extended;
begin
  Result := Round(e * 100000000) / 100000000;
end;

function ToIdent(const s: String): String;
var
  I: Integer;
begin
  Result := '';
  for i := 1 to Length(s) do
    if i = 1 then
    begin
{$IFDEF Delphi12}
      if CharInSet(s[i], ['A'..'Z','a'..'z','_']) then
{$ELSE}
      if s[i] in ['A'..'Z','a'..'z','_'] then
{$ENDIF}
        Result := Result + s[i]
    end
{$IFDEF Delphi12}
    else if CharInSet(s[i], ['A'..'Z','a'..'z','_','0'..'9']) then
{$ELSE}
    else if s[i] in ['A'..'Z','a'..'z','_','0'..'9'] then
{$ENDIF}
      Result := Result + s[i];
  if Length(Result) < Length(s) * 2 div 3 then
    Result := 'Memo';
end;


{ TfrxVirtualGuides }

constructor TfrxVirtualGuides.Create;
begin
  inherited Create(TfrxGuideItem);
end;

procedure TfrxVirtualGuides.Add(Left, Top, Right, Bottom: Extended);
var
  Item: TfrxGuideItem;
begin
  Item := TfrxGuideItem(inherited Add);
  Item.Left := Left;
  Item.Top := Top;
  Item.Right := Right;
  Item.Bottom := Bottom;
end;

function TfrxVirtualGuides.GetGuides(Index: Integer): TfrxGuideItem;
begin
  Result := TfrxGuideItem(inherited Items[Index]);
end;


{ TDesignerWorkspace }

constructor TDesignerWorkspace.Create(AOwner: TComponent);
begin
  inherited;
  FDesigner := TfrxDesignerForm(AOwner);
  FVirtualGuides := TfrxVirtualGuides.Create;
  FVirtualGuideObjects := TList.Create;
end;

destructor TDesignerWorkspace.Destroy;
begin
  FVirtualGuides.Free;
  FVirtualGuideObjects.Free;
  inherited;
end;

procedure TDesignerWorkspace.DeleteObjects;
var
  i: Integer;
  NeedReload: Boolean;
begin
  NeedReload := False;
  for i := 0 to FSelectedObjects.Count - 1 do
    if TObject(FSelectedObjects[i]) is TfrxSubreport then
      NeedReload := True;

  FMemo := nil;
  inherited;

  if NeedReload then
    FDesigner.ReloadPages(FDesigner.Report.Objects.IndexOf(Page));
end;

procedure TDesignerWorkspace.SetInsertion(AClass: TfrxComponentClass;
  AWidth, AHeight: Extended; AFlag: Word);
begin
  inherited;
  CreateVirtualGuides;
end;

procedure TDesignerWorkspace.DrawObjects;
var
  r: TRect;
  i, d: Integer;
begin
  if FDesigner.Page is TfrxReportPage then
    with TfrxReportPage(FDesigner.Page) do
      if Columns > 1 then
        for i := 0 to Columns - 1 do
        begin
          d := Round(frxStrToFloat(ColumnPositions[i]) * fr01cm * FScale);
          if d = 0 then continue;
          FCanvas.Pen.Color := clSilver;
          FCanvas.MoveTo(d, 0);
          FCanvas.LineTo(d, Self.Height);
        end;

  if FShowGuides and (FPage is TfrxReportPage) then
  begin
    with FCanvas do
    begin
      Pen.Width := 1;
      Pen.Style := psSolid;
      Pen.Color := $FFCC00;
      Pen.Mode := pmCopy;
    end;

    for i := 0 to HGuides.Count - 1 do
    begin
      d := Round(frxStrToFloat(HGuides[i]) * Scale);
      FCanvas.MoveTo(0, d);
      FCanvas.LineTo(Width, d);
    end;

    for i := 0 to VGuides.Count - 1 do
    begin
      d := Round(frxStrToFloat(VGuides[i]) * Scale);
      FCanvas.MoveTo(d, 0);
      FCanvas.LineTo(d, Height);
    end;
  end;

  inherited;

  if (FMemo <> nil) and FDesigner.DropFields then
    with FCanvas do
    begin
      r.TopLeft := Point(Round((FMemo.Left + FMemo.Width) * FScale) - 16,
                         Round((FMemo.AbsTop) * FScale) + 2);
      r.BottomRight := Point(r.Left + 16, r.Top + 16);
      DrawButtonFace(FCanvas, r, 1, bsNew, False, False, False);

      Brush.Color := clBlack;
      Brush.Style := bsSolid;
      Pen.Color := clBlack;
      Pen.Style := psSolid;
      FCanvas.Polygon([Point(r.Left + 4, r.Top + 6), Point(r.Left + 7, r.Top + 9),
        Point(r.Left + 10, r.Top + 6), Point(r.Left + 4, r.Top + 6)]);
    end;


  if FVirtualGuides.Count > 0 then
  begin
    if FMouseDown or (FMode1 = dmInsertObject) or (FMode1 = dmInsertLine) then
      with FCanvas do
      begin
        Pen.Width := 1;
        Pen.Style := psSolid;
        Pen.Color := $FFCC00;
        Pen.Mode := pmCopy;
        for i := 0 to FVirtualGuides.Count - 1 do
        begin
          MoveTo(Round(FVirtualGuides[i].Left * Scale), Round(FVirtualGuides[i].Top * Scale));
          LineTo(Round(FVirtualGuides[i].Right * Scale), Round(FVirtualGuides[i].Bottom * Scale));
        end;
      end;
    FVirtualGuides.Clear;
  end;
end;

procedure TDesignerWorkspace.DragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var
  ds: TfrxDataset;
  s, fld: String;
  w: Integer;
begin
  Accept := ((FDesigner.CheckOp(drDontInsertObject) and
    (Source is TTreeView) and
    (TTreeView(Source).Owner = FDesigner.DataTree) and
    (FDesigner.DataTree.GetFieldName <> '')) or
    ((Source is TfrxRuler) and FDesigner.ShowGuides)) and (FDesigner.Page is TfrxReportPage);
  if not Accept then Exit;

  FMode := dmDrag;
  if Source is TfrxRuler then
    with Canvas do
    begin
      Pen.Width := 1;
      Pen.Style := psSolid;
      Pen.Color := clBlack;
      Repaint;

      if GridAlign then
      begin
        X := Round(Trunc(X / (GridX * Scale)) * GridX * Scale);
        Y := Round(Trunc(Y / (GridY * Scale)) * GridY * Scale);
      end;

      if TfrxRuler(Source).Align = alLeft then
      begin
        MoveTo(X, 0);
        LineTo(X, Height);
      end
      else
      begin
        MoveTo(0, Y);
        LineTo(Width, Y);
      end;

      MouseMove([], X, Y);
    end
  else
  begin
    if (FInsertion.ComponentClass = nil) and
      (FDesigner.DataTree.InsFieldCB.Checked or
      FDesigner.DataTree.InsCaptionCB.Checked or
      not FDesigner.DataTree.IsDataField) then
    begin
      s := FDesigner.DataTree.GetFieldName;
      s := Copy(s, 2, Length(s) - 2);
      FDesigner.Report.GetDatasetAndField(s, ds, fld);
      try
        if (ds <> nil) and (fld <> '') then
          w := ds.DisplayWidth[fld] else
          w := 10;
      except
        w := 10;
      end;

      if w > 100 then
        w := 100;

      SetInsertion(TfrxMemoView, Round(w * 8 / GridX) * GridX,
        FDesigner.GetDefaultObjectSize.Y, 0);
    end;

    MouseMove([], X - 8,  Y - 8);
  end;
end;

procedure TDesignerWorkspace.DragDrop(Source: TObject; X, Y: Integer);
var
  eX, eY: Extended;
  m: TfrxCustomMemoView;
  ds: TfrxDataset;
  s, fld: String;
begin
  if (Source is TfrxRuler) and (FPage is TfrxReportPage) then
  begin
    if GridAlign then
    begin
      eX := Trunc(X / Scale / GridX) * GridX;
      eY := Trunc(Y / Scale / GridY) * GridY;
    end
    else
    begin
      eX := X / Scale;
      eY := Y / Scale;
    end;

    eX := Round8(eX);
    eY := Round8(eY);

    if TfrxRuler(Source).Align = alLeft then
      VGuides.Add(FloatToStr(eX)) else
      HGuides.Add(FloatToStr(eY));
    FMode := dmSelect;
  end
  else if (FDesigner.DataTree.InsFieldCB.Checked or
    FDesigner.DataTree.InsCaptionCB.Checked or
    not FDesigner.DataTree.IsDataField){$IFDEF FR_COM} and not FDesigner.IsExpired{$ENDIF} then
  begin
    FSelectedObjects.Clear;

    if Page is TfrxDMPPage then
      m := TfrxDMPMemoView.Create(Page)
    else
      m := TfrxMemoView.Create(Page);
    s := ToIdent(FDesigner.DataTree.GetFieldName);
    if (s <> 'Memo') and (FDesigner.Report.FindObject(s) = nil) then
      m.Name := s
    else
    begin
      THackMemo(m).FBaseName := s;
      m.CreateUniqueName;
    end;
    m.IsDesigning := True;
    s := FDesigner.DataTree.GetFieldName;
    s := Copy(s, 2, Length(s) - 2);
    FDesigner.Report.GetDataSetAndField(s, ds, fld);

    if not FDesigner.DataTree.IsDataField or FDesigner.DataTree.InsFieldCB.Checked then
    begin
      m.DataSet := ds;
      m.DataField := fld;
      if (ds = nil) and (fld = '') then
      begin
        if Pos('<', FDesigner.DataTree.GetFieldName) = 1 then
          m.Text := '[' + s + ']' else
          m.Text := '[' + FDesigner.DataTree.GetFieldName + ']';
      end;
      m.SetBounds(Round8(FInsertion.Left), Round8(FInsertion.Top),
        Round8(FInsertion.Width), Round8(FInsertion.Height));
      FDesigner.SampleFormat.ApplySample(m);
      FObjects.Add(m);
      FSelectedObjects.Add(m);
      FInsertion.Top := FInsertion.Top - FInsertion.Height;
    end
    else
      m.Free;
    if FDesigner.DataTree.IsDataField and FDesigner.DataTree.InsCaptionCB.Checked then
    begin
      if Page is TfrxDMPPage then
        m := TfrxDMPMemoView.Create(Page) else
        m := TfrxMemoView.Create(Page);
      m.CreateUniqueName;
      m.IsDesigning := True;
      m.Text := fld;
      m.SetBounds(Round8(FInsertion.Left), Round8(FInsertion.Top),
        Round8(FInsertion.Width), Round8(FInsertion.Height));
      FDesigner.SampleFormat.ApplySample(m);
      FObjects.Add(m);
      FSelectedObjects.Add(m);
    end;

    SetInsertion(nil, 0, 0, 0);
  end;

  FModifyFlag := True;
  MouseUp(mbLeft, [], X,  Y);
  SelectionChanged;
end;

procedure TDesignerWorkspace.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  ds: TfrxDataset;
  r: TRect;
  p: TPoint;

  function Contain(c: TfrxComponent): Boolean;
  begin
    Result := (X / FScale >= c.Left + c.Width - 16) and (X / FScale <= c.Left + c.Width) and
      (Y / FScale >= c.AbsTop) and (Y / FScale <= c.AbsTop + 16);
  end;

begin
  if FDisableUpdate then Exit;

  if FTool = dtHand then
  begin
    FMode1 := dmNone;
    FMouseDown := True;
    FLastMousePointX := X;
    FLastMousePointY := Y;
    Exit;
  end
  else if FTool in [dtZoom, dtText] then
  begin
    FMode1 := dmSelectionRect;
    FSelectionRect := frxRect(X, Y, X, Y);
  end
  else if FTool = dtFormat then
  begin
    FMode1 := dmNone;
    Exit;
  end;

  if (FMode = dmSelect) and (FMemo <> nil) and Contain(FMemo) and FDesigner.DropFields then
  begin
    FPopupForm := TfrxPopupForm.Create(Self);
    FPopupForm.OnDestroy := DoPopupHide;
    FListBox := TListBox.Create(FPopupForm);
    with FListBox do
    begin
      Parent := FPopupForm;
      Ctl3D := False;
      Align := alClient;
      Style := lbOwnerDrawFixed;
      ItemHeight := 16;
      OnClick := DoLBClick;
      OnDrawItem := LBDrawItem;
      r.Top := Round(FMemo.AbsTop * FScale) + 18;
      r.Right := Round((FMemo.Left + FMemo.Width) * FScale);
      r.Left := r.Right - 140;
      r.Bottom := r.Top + 162;

      if r.Left < 0 then
      begin
        Inc(r.Right, -r.Left);
        r.Left := 0;
      end;

      p := Self.ClientToScreen(r.TopLeft);
      FPopupForm.SetBounds(p.X, p.Y, r.Right - r.Left, r.Bottom - r.Top);

      ds := TfrxDataBand(FMemo.Parent).Dataset;
      if ds <> nil then
      begin
        ds.GetFieldList(Items);
        ItemIndex := Items.IndexOf(FMemo.DataField);
        FPopupForm.Show;
        FPopupFormVisible := True;
      end;
    end;

    FMode1 := dmNone;
    FMouseDown := False;
    Exit;
  end;

  if not ((FTool = dtZoom) and (Button = mbRight)) then
    inherited;

  CreateVirtualGuides;
end;

procedure TDesignerWorkspace.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  i, px, py: Integer;
  c, cOver: TfrxComponent;
  ds: TfrxDataset;
  e, kx, ky: Extended;

  function Contain(c: TfrxComponent): Boolean;
  begin
    Result := (X / FScale >= c.Left) and (X / FScale <= c.Left + c.Width - 4) and
      (Y / FScale >= c.AbsTop) and (Y / FScale <= c.AbsTop + c.Height);
  end;

  function GridCheck: Boolean;
  begin
    Result := (kx >= GridX) or (kx <= -GridX) or
              (ky >= GridY) or (ky <= -GridY);
    if Result then
    begin
      kx := Trunc(kx / GridX) * GridX;
      ky := Trunc(ky / GridY) * GridY;
    end;
  end;

begin
  if FDisableUpdate then Exit;