fr_cross.pas

不错的报表工具

{******************************************}
{                                          }
{             FastReport v2.5              }
{              Cross object                }
{                                          }
{Copyright(c) 1998-2003 by FastReports Inc.}
{                                          }
{******************************************}
{ Advanced Cross-tab object                }
{ Copyright(c) by Pavel Ishenin            }
{ <[e-mail]>                       }
{******************************************}


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, Buttons, fr_crossd;

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

  TfrCrossView = class(TfrView)
  private
    FCross: TfrCross;
    FColumnWidths: TQuickIntArray;
    FColumnHeights: TQuickIntArray;
    LastTotalCol: TQuickIntArray;
    FFlag: Boolean;
    FSkip: Boolean;
    FRowDS: TfrUserDataset;
    FColumnDS: TfrUserDataset;
    FRepeatCaptions: Boolean;
    FSavedOnBeginDoc: TBeginDocEvent;
    FSavedOnBeforePrint: TEnterRectEvent;
    FSavedOnPrintColumn: TPrintColumnEvent;
    FSavedOnEndDoc: TEndDocEvent;
    FReport: TfrReport;
    MaxGTHeight, MaxCellHeight: Integer; 
    LastX: Integer;                      
    DefDY : Integer;                     
    MaxString : String;                  
    LongNames : TStringList;             
    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);
    procedure P3Click(Sender: TObject);
    function  GetDataCellText : String;  
    procedure DictionaryEditor(Sender : TObject);
    function  GetDictName(s : String) : String;  
    function  CheckLongName(s : String) : String;
    function  FormatedLongNames : String;        
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function  GetPropValue(Index: String): Variant; override;
  public
    FShowHeader: Boolean;
    FInternalFrame: Boolean;
    FShowGrandTotal: Boolean;
    FDataWidth  : Integer;    
    FHeaderWidth: Integer;    
    FDictionary: TStringList; 
    FMaxNameLen: Integer;     
    FDataCaption: String;     
    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;
    SpeedButton1: TSpeedButton;
    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);
    procedure SpeedButton1Click(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;

var 
  GrandTotalStr, TotalStr, TotalOfStr, CellStr, HeaderStr : String;

implementation

{$R *.DFM}

uses FR_Const, FR_DBRel, FR_Utils
{$IFDEF Delphi6}
, Variants
{$ENDIF}
;

type
  TDrawPanel = class(TPanel)
  private
    RowTotals : Integer;
    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;
  THackUserDataset = class(TfrUserDataset)
  end;

var
  frCrossForm: TfrCrossForm;
  frCrossList: TfrCrossList;

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

{ 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;
  frCrossList.Add(Self);
  DefDY := 18;
  FDictionary := TStringList.Create;
  FShowHeader     := True;
  FInternalFrame  := False;
  FShowGrandTotal := True;
  FDataWidth      := -1;
  FHeaderWidth    := -1;
  FMaxNameLen     := 100;
  FDataCaption    := 'Data';

  GrandTotalStr := frLoadStr(frRes + 2600);
  TotalStr := frLoadStr(frRes + 2601); 
  TotalOfStr := frLoadStr(frRes + 2602); 
  CellStr := frLoadStr(frRes + 2603); 
  HeaderStr := frLoadStr(frRes + 2604); 

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);
  frCrossList.Delete(Self);
  FDictionary.Free;
  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 := DefDY;
    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', HeaderStr);                

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

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

  OneObject('RowHeaderMemo', HeaderStr);                   

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

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

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

procedure TfrCrossView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('InternalFrame', [frdtBoolean], nil);
  AddProperty('RepeatCaptions', [frdtBoolean], nil);
  AddProperty('ShowHeader', [frdtBoolean], nil);        
  AddProperty('ShowGrandTotal', [frdtBoolean], nil);    
  AddProperty('DataWidth', [frdtInteger], nil);         
  AddProperty('HeaderWidth', [frdtInteger], nil);       
  AddProperty('Dictionary', [frdtOneObject, frdtHasEditor], DictionaryEditor);
  AddProperty('MaxNameLen', [frdtInteger], nil);
  AddProperty('DataCaption', [frdtString], 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
  else if Index = 'SHOWGRANDTOTAL' then
    FShowGrandTotal := Value
  else if Index = 'DATAWIDTH' then
    FDataWidth := Value
  else if Index = 'HEADERWIDTH' then
    FHeaderWidth := Value
  else if Index = 'MAXNAMELEN' then
    FMaxNameLen := Value
  else if Index = 'DATACAPTION' then