fr_cross.pas

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

{******************************************}
{                                          }
{             FastReport v2.4              }
{              Cross object                }
{                                          }
{ Copyright (c) 1998-2000 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_Cross;

interface

{$I FR.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus, FR_Class, FR_Cross1, FR_DSet, ExtCtrls
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TfrCrossObject = class(TComponent)  // fake component
  end;

  TfrCrossView = class(TfrView)
  private
    FCross: TfrCross;
    FColumnWidths: Variant;
    FColumnHeights: Variant;
    FFlag: Boolean;
    FSkip: Boolean;
    FRowDS: TfrUserDataset;
    FColumnDS: TfrUserDataset;
    FRepeatCaptions: Boolean;
    FShowHeader: Boolean;
    FInternalFrame: Boolean;
    FSavedOnBeginDoc: TBeginDocEvent;
    FSavedOnBeforePrint: TEnterRectEvent;
    FSavedOnPrintColumn: TPrintColumnEvent;
    FSavedOnEndDoc: TEndDocEvent;
    FReport: TfrReport;
    procedure CreateObjects;
    procedure CalcWidths;
    procedure MakeBands;
    procedure ReportPrintColumn(ColNo: Integer; var Width: Integer);
    procedure ReportBeforePrint(Memo: TStringList; View: TfrView);
    procedure ReportEndDoc;
    procedure ReportBeginDoc;
    procedure P1Click(Sender: TObject);
    procedure P2Click(Sender: TObject);
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(Canvas: TCanvas); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  end;

  TfrCrossForm = class(TForm)
    Image1: TImage;
    GroupBox1: TGroupBox;
    ListBox2: TListBox;
    ListBox3: TListBox;
    ListBox4: TListBox;
    Shape1: TShape;
    Shape2: TShape;
    GroupBox2: TGroupBox;
    DatasetsLB: TComboBox;
    FieldsLB: TListBox;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    ComboBox2: TComboBox;
    CheckBox1: TCheckBox;
    procedure FormShow(Sender: TObject);
    procedure DatasetsLBClick(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure ListBox3Enter(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure ListBox3Click(Sender: TObject);
    procedure ListBox4Click(Sender: TObject);
    procedure ComboBox2Click(Sender: TObject);
    procedure ListBox4DrawItem(Control: TWinControl; Index: Integer;
      ARect: TRect; State: TOwnerDrawState);
    procedure FieldsLBDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure FieldsLBDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure ListBox3DblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FListBox: TListBox;
    FBusy: Boolean;
    DrawPanel: TPanel;
    procedure FillDatasetsLB;
    procedure Localize;
    procedure ClearSelection(Sender : TObject);
  public
    { Public declarations }
    Cross: TfrCrossView;
  end;


implementation

{$R *.DFM}

uses FR_Const, FR_DBRel, FR_Utils;

type
  TDrawPanel = class(TPanel)
  private
    FColumnFields: TStrings;
    FRowFields: TStrings;
    FCellFields: TStrings;
    LastX, LastY, DefDx, DefDy : Integer;
    procedure Draw(x, y, dx ,dy: Integer; s: String);
    procedure DrawColumnCells;
    procedure DrawRowCells;
    procedure DrawCellField;
    procedure DrawBorderLines(pos : byte);
  public
    procedure Paint; override;
  end;

  TfrCrossList = class
  private
    FList: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(v: TfrCrossView);
    procedure Delete(v: TfrCrossView);
  end;

  TfrCrossLists = class
  private
    FList: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(v: TfrCrossView);
    procedure Delete(v: TfrCrossView);
  end;

var
  frCrossForm: TfrCrossForm;
  frCrossLists: TfrCrossLists;


function PureName1(s: String): String;
begin
  if Pos('+', s) <> 0 then
    Result := Copy(s, 1, Pos('+', s) - 1) else
    Result := s;
end;


{ TfrCrossList }

constructor TfrCrossList.Create;
begin
  FList := TList.Create;
end;

destructor TfrCrossList.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

procedure TfrCrossList.Add(v: TfrCrossView);
begin
  FList.Add(v);
  v.FSavedOnBeginDoc := v.FReport.OnCrossBeginDoc;
  v.FReport.OnCrossBeginDoc := v.ReportBeginDoc;
  v.FSavedOnBeforePrint := v.FReport.OnBeforePrint;
  v.FReport.OnBeforePrint := v.ReportBeforePrint;
  v.FSavedOnPrintColumn := v.FReport.OnPrintColumn;
  v.FReport.OnPrintColumn := v.ReportPrintColumn;
  v.FSavedOnEndDoc := v.FReport.OnEndDoc;
  v.FReport.OnEndDoc := v.ReportEndDoc;
end;

procedure TfrCrossList.Delete(v: TfrCrossView);
var
  i: Integer;
  v1: TfrCrossView;
begin
  v.FReport.OnCrossBeginDoc := v.FSavedOnBeginDoc;
  v.FReport.OnBeforePrint := v.FSavedOnBeforePrint;
  v.FReport.OnPrintColumn := v.FSavedOnPrintColumn;
  v.FReport.OnEndDoc := v.FSavedOnEndDoc;

  i := FList.IndexOf(v);
  FList.Delete(i);

  if (i = 0) and (FList.Count > 0) then
  begin
    v := TfrCrossView(FList[0]);
    v.FSavedOnBeginDoc := v.FReport.OnCrossBeginDoc;
    v.FSavedOnEndDoc := v.FReport.OnEndDoc;
    v.FSavedOnBeforePrint := v.FReport.OnBeforePrint;
    v.FSavedOnPrintColumn := v.FReport.OnPrintColumn;
  end;

  for i := 1 to FList.Count - 1 do
  begin
    v := TfrCrossView(FList[i]);
    v1 := TfrCrossView(FList[i - 1]);
    v.FSavedOnBeginDoc := v1.ReportBeginDoc;
    v.FSavedOnEndDoc := v1.ReportEndDoc;
    v.FSavedOnBeforePrint := v1.ReportBeforePrint;
    v.FSavedOnPrintColumn := v1.ReportPrintColumn;
  end;

  if FList.Count > 0 then
  begin
    v := TfrCrossView(FList[FList.Count - 1]);
    v.FReport.OnCrossBeginDoc := v.ReportBeginDoc;
  end;
end;


{ TfrCrossLists }

constructor TfrCrossLists.Create;
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TfrCrossLists.Destroy;
var
  cl: TfrCrossList;
begin
  while FList.Count > 0 do
  begin
    cl := FList[0];
    cl.Free;
    FList.Delete(0);
  end;
  FList.Free;
  inherited Destroy;
end;

procedure TfrCrossLists.Add(v: TfrCrossView);
var
  i, Index: Integer;
  cl: TfrCrossList;
begin
  Index := -1;
  for i := 0 to FList.Count - 1 do
  begin
    cl := FList[i];
    if (cl.FList.Count > 0) and (TfrCrossView(cl.FList[0]).FReport = v.FReport) then
    begin
      Index := i;
      break;
    end;
  end;
  if Index = -1 then
  begin
    cl := TfrCrossList.Create;
    FList.Add(cl);
    Index := FList.Count - 1;
  end;
  cl := FList[Index];
  cl.Add(v);
end;

procedure TfrCrossLists.Delete(v: TfrCrossView);
var
  i, Index: Integer;
  cl: TfrCrossList;
begin
  Index := -1;
  for i := 0 to FList.Count - 1 do
  begin
    cl := FList[i];
    if (cl.FList.Count > 0) and (TfrCrossView(cl.FList[0]).FReport = v.FReport) then
    begin
      Index := i;
      break;
    end;
  end;
  if Index <> -1 then
  begin
    cl := FList[Index];
    cl.Delete(v);
    if cl.FList.Count = 0 then
    begin
      cl.Free;
      FList.Delete(Index);
    end;
  end;
end;


{ TfrCrossView }

constructor TfrCrossView.Create;
begin
  inherited Create;
  FCross := nil;
  Typ := gtAddIn;
  BaseName := 'Cross';
  Flags := Flags + flDontUndo + flOnePerPage;
  FrameTyp := 15;
  Restrictions := frrfDontEditMemo + frrfDontSize;
  dx := 348;
  dy := 94;
  Visible := False;
  FReport := CurReport;
  frCrossLists.Add(Self);
end;

destructor TfrCrossView.Destroy;
var
  i: Integer;
  p: TfrPage;

  procedure Del(s: String);
  var
    v: TfrView;
  begin
    if p <> nil then
    begin
      v := p.FindObject(s);
      if v <> nil then
        p.Delete(p.Objects.IndexOf(v));
    end;
  end;

begin
  p := nil;
  for i := 0 to FReport.Pages.Count - 1 do
    if FReport.Pages[i].FindObject(Self.Name) <> nil then
    begin
      p := FReport.Pages[i];
      break;
    end;

  Del('ColumnHeaderMemo' + Name);
  Del('ColumnTotalMemo' + Name);
  Del('GrandColumnTotalMemo' + Name);
  Del('RowHeaderMemo' + Name);
  Del('CellMemo' + Name);
  Del('RowTotalMemo' + Name);
  Del('GrandRowTotalMemo' + Name);
  frCrossLists.Delete(Self);
  inherited Destroy;
end;

procedure TfrCrossView.CreateObjects;
var
  v: TfrMemoView;
  i: Integer;
  p: TfrPage;

  function OneObject(Name1, Name2: String): TfrMemoView;
  begin
    Result := TfrMemoView(frCreateObject(gtMemo, ''));
    Result.Name := Name1 + Name;
    Result.Memo.Add(Name2);
    Result.Font.Style := [fsBold];
    Result.dx := 80;
    Result.dy := 18;
    Result.Visible := False;
    Result.Alignment := frtaCenter + frtaMiddle;
    Result.FrameTyp := 15;
    Result.Restrictions := frrfDontSize + frrfDontMove + frrfDontDelete;
    p.Objects.Add(Result);
  end;

begin
  p := nil;
  for i := 0 to FReport.Pages.Count - 1 do
    if FReport.Pages[i].FindObject(Self.Name) <> nil then
    begin
      p := FReport.Pages[i];
      break;
    end;

  OneObject('ColumnHeaderMemo', 'Header');

  v := OneObject('ColumnTotalMemo', 'Total');
  v.FillColor := $F5F5F5;

  v := OneObject('GrandColumnTotalMemo', 'Grand total');
  v.FillColor := clSilver;

  OneObject('RowHeaderMemo', 'Header');

  v := OneObject('CellMemo', 'Cell');
  v.Alignment := frtaRight;
  v.Font.Style := [];

  v := OneObject('RowTotalMemo', 'Total');
  v.FillColor := $F5F5F5;

  v := OneObject('GrandRowTotalMemo', 'Grand total');
  v.FillColor := clSilver;
end;

procedure TfrCrossView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('InternalFrame', [frdtBoolean], nil);
  AddProperty('RepeatCaptions', [frdtBoolean], nil);
  DelProperty('Name');
end;

procedure TfrCrossView.SetPropValue(Index: String; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'INTERNALFRAME' then
    FInternalFrame := Value
  else if Index = 'REPEATCAPTIONS' then
    FRepeatCaptions := Value
  else if Index = 'SHOWHEADER' then
    FShowHeader := Value
end;

function TfrCrossView.GetPropValue(Index: String): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'INTERNALFRAME' then
    Result := FInternalFrame
  else if Index = 'REPEATCAPTIONS' then
    Result := FRepeatCaptions
  else if Index = 'SHOWHEADER' then
    Result := FShowHeader
end;

procedure TfrCrossView.ShowEditor;
begin
  frCrossForm.Cross := Self;
  frCrossForm.ShowModal;
end;

procedure TfrCrossView.Draw(Canvas: TCanvas);
var
  v: TfrView;
begin
  if FReport.FindObject('ColumnHeaderMemo' + Name) = nil then
    CreateObjects;
  BeginDraw(Canvas);
  CalcGaps;
  ShowBackground;
  ShowFrame;

  v := FReport.FindObject('ColumnHeaderMemo' + Name);
  v.SetBounds(x + 92, y + 8, v.dx, v.dy);
  v.Draw(Canvas);

  v := FReport.FindObject('ColumnTotalMemo' + Name);
  v.SetBounds(x + 176, y + 8, v.dx, v.dy);
  v.Draw(Canvas);

  v := FReport.FindObject('GrandColumnTotalMemo' + Name);
  v.SetBounds(x + 260, y + 8, v.dx, v.dy);
  v.Draw(Canvas);

  v := FReport.FindObject('RowHeaderMemo' + Name);
  v.SetBounds(x + 8, y + 28, v.dx, v.dy);
  v.Draw(Canvas);

  v := FReport.FindObject('CellMemo' + Name);
  v.SetBounds(x + 92, y + 28, v.dx, v.dy);
  v.Draw(Canvas);