frd_mngr.pas

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

{******************************************}
{                                          }
{     FastReport v2.4 - Data storage       }
{              Main unit                   }
{                                          }
{ Copyright (c) 1998-2000 by Tzyganenko A. }
{                                          }
{******************************************}

unit FRD_Mngr;

interface

{$I FR.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Forms, Dialogs, StdCtrls,
  DB, FR_Class, FR_Intrp, FR_DSet, FR_DBSet, FRD_Wrap, FR_DBRel
{$IFDEF IBX}, IBTable, IBQuery, IBDatabase{$ENDIF}
{$IFDEF ADO}, ADODB{$ENDIF}
{$IFDEF BDE}, DBTables{$ENDIF};

type
  TQueryParamsEvent = procedure(Report: TfrReport; Query: TfrQuery) of object;

  TfrDataStorage = class(TComponent)
  private
    FOnQueryParams: TQueryParamsEvent;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property OnQueryParams: TQueryParamsEvent read FOnQueryParams write FOnQueryParams;
  end;

  TfrReportDataManager = class(TfrDataManager)
  private
    FEnabled: Boolean;
  public
    procedure Clear; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure BeforePreparing; override;
    procedure AfterPreparing; override;
    procedure PrepareDataSet(ds: TfrTDataSet); override;
    function ShowParamsDialog: Boolean; override;
    procedure AfterParamsDialog; override;
    procedure OnMngrClick(Sender: TObject);
    procedure OnParmClick(Sender: TObject);
  end;

  PfrControlInfo = ^TfrControlInfo;
  TfrControlInfo = record
    Bounds: TRect;
    Caption: String[255];
    FontName: String[32];
    FontSize: Integer;
    FontStyle: Word;
    FontCharset: Word;
    FontColor: TColor;
  end;

  PfrParamInfo = ^TfrParamInfo;
  TfrParamInfo = record
    Actual: Boolean;
    QueryRef: TfrQuery;
    QueryName, ParamName: String[255];
    LabelControl, EditControl: TfrControlInfo;
    Typ: Byte; // 0 - edit; 1 - lookup; 2 - combo
    LookupActive: Boolean;
    LookupDS: String[255];
    LookupKF, LookupLF: String[32];
    ComboStrings: TStrings;
  end;

function GetDataSource(d: TDataSet): TDataSource;
function GetFRDataSet(d: TDataSet): TfrDBDataSet;
function GetDataPath(d: TDataSet): String;
function FindFieldDef(DataSet: TDataSet; FName: String): TFieldDef;
function GetDataSetName(Owner: TComponent; d: TDataSource): String;
procedure GetDatabaseList(List: TStrings);


var
  frDataModule: TDataModule;
  frParamList: TList;


const
  FieldNum = 10;
  ParamTypes: Array[0..10] of TFieldType =
    (ftBCD, ftBoolean, ftCurrency, ftDate, ftDateTime, ftInteger,
     ftFloat, ftSmallint, ftString, ftTime, ftWord);

  FieldClasses: array[0..FieldNum - 1] of TFieldClass = (
    TStringField, TSmallintField, TIntegerField, TWordField,
    TBooleanField, TFloatField, TCurrencyField, TDateField,
    TTimeField, TBlobField);
  ptEdit = 0;
  ptCombo = 1;
  ptLookup = 2;

implementation

uses FRD_List, FRD_Form, FR_Const, FR_Utils;

{$R *.RES}

var
  Bmp1, Bmp2: TBitmap;
  frDataStorage: TfrDataStorage;

{----------------------------------------------------------------------------}
function GetDataSource(d: TDataSet): TDataSource;
var
  i: Integer;

  function EnumComponents(f: TComponent): TDataSource;
  var
    i: Integer;
    c: TComponent;
  begin
    Result := nil;
    for i := 0 to f.ComponentCount - 1 do
    begin
      c := f.Components[i];
      if (c is TDataSource) and ((c as TDataSource).DataSet = d) then
      begin
        Result := c as TDataSource;
        break;
      end;
    end;
  end;

begin
  Result := nil;
  for i := 0 to Screen.FormCount - 1 do
  begin
    Result := EnumComponents(Screen.Forms[i]);
    if Result <> nil then Exit;
  end;
  for i := 0 to Screen.DataModuleCount - 1 do
  begin
    Result := EnumComponents(Screen.DataModules[i]);
    if Result <> nil then Exit;
  end;
end;

function GetFRDataSet(d: TDataSet): TfrDBDataSet;
var
  i: Integer;
  ds: TDataSource;
begin
  Result := nil;
  ds := GetDataSource(d);
  if ds <> nil then
    with frDataModule do
    for i := 0 to ComponentCount - 1 do
      if Components[i] is TfrDBDataSet then
        if TDataSource((Components[i] as TfrDBDataSet).DataSource) = ds then
        begin
          Result := Components[i] as TfrDBDataSet;
          break;
        end;
end;

function GetDataPath(d: TDataSet): String;
var
  s: String;
begin
  s := '';
  if d <> nil then
    if d is TfrTable then
    begin
      s := TfrTable(d).frDatabaseName;
      if s <> '' then
        if (Pos('\', s) = 0) and (Pos(':', s) = 0) then
          s := ':' + s + ':' else
          if s[Length(s)] <> '\' then s := s + '\';
      s := s + TfrTable(d).TableName;
    end
    else if d is TfrQuery then
      s := TfrQuery(d).frDatabaseName;
  Result := s;
end;

function FindFieldDef(DataSet: TDataSet; FName: String): TFieldDef;
var
  i: Integer;
begin
  Result := nil;
  with DataSet do
  for i := 0 to FieldDefs.Count - 1 do
    if AnsiCompareText(FieldDefs.Items[i].Name, FName) = 0 then
    begin
      Result := FieldDefs.Items[i];
      break;
    end;
end;

function GetDataSetName(Owner: TComponent; d: TDataSource): String;
begin
  Result := '';
  if (d <> nil) and (d.DataSet <> nil) then
  begin
    Result := d.Dataset.Name;
    if d.Dataset.Owner <> Owner then
      Result := d.Dataset.Owner.Name + '.' + Result;
  end;
end;

procedure ClearParamList;
begin
  while frParamList.Count > 0 do
  begin
    PfrParamInfo(frParamList[0])^.ComboStrings.Free;
    FreeMem(PfrParamInfo(frParamList[0]), SizeOf(TfrParamInfo));
    frParamList.Delete(0);
  end;
end;

procedure GetDatabaseList(List: TStrings);
begin
{$IFDEF BDE}
  Session.GetAliasNames(List);
{$ENDIF}
{$IFDEF IBX}
   frGetComponents(frDataModule, TIBDatabase, List, nil);
{$ENDIF}
{$IFDEF ADO}
   frGetComponents(frDataModule, TADOConnection, List, nil);
{$ENDIF}
end;


{-----------------------------------------------------------------------------}
constructor TfrDataStorage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frDataStorage := Self;
end;

{-----------------------------------------------------------------------------}
procedure TfrReportDataManager.Clear; 
begin
  with frDataModule do
    while ComponentCount > 0 do
      Components[0].Free;
  ClearParamList;
end;

procedure TfrReportDataManager.LoadFromStream(Stream: TStream);
var
  i: Integer;
  b: Byte;
  n: Word;
  sl: TStringList;
  Version23: Boolean;

  function ReadString: String;
  begin
    frReadMemo(Stream, sl);
    if sl.Count > 0 then
      Result := sl[0] else
      Result := '';
  end;

  procedure CreateDataSources(ds: TDataset);
  var
    d: TDataSource;
    d1: TfrDBDataSet;
  begin
    d := TDataSource.Create(frDataModule);
    d.DataSet := ds;
    d.Name := 'S' + ds.Name;

    d1 := TfrDBDataSet.Create(frDataModule);
    d1.DataSource := d;
    d1.Name := '_' + ds.Name;
    d1.CloseDataSource := True;
  end;

  procedure ReadFields(ds: TDataSet);
  var
    i: Integer;
    b: Byte;
    w, n: Word;
    s: String;
    Field: TField;
    ds1: TDataset;
  begin
    Stream.Read(n, 2);
    for i := 0 to n - 1 do
    begin
      Stream.Read(b, 1);
      s := ReadString;
      if b = 0 then
        FindFieldDef(ds, s).CreateField(ds)
      else
      begin
        Stream.Read(b, 1);
        Field := FieldClasses[b].Create(ds);
        with Field do
        begin
          FieldName := s;
          Dataset := ds;
          Stream.Read(w, 2);
          Size := w;
          Lookup := True;
          KeyFields := ReadString;
          s := ReadString;
          ds1 := frFindComponent(frDataModule, s) as TDataset;
          LookupDataset := ds1;
          LookupKeyFields := ReadString;
          LookupResultField := ReadString;
        end;
      end;
    end;
  end;

  procedure ReadParams(q: TfrQuery);
  var
    i: Integer;
    w, n: Word;
    s: String;
  begin
    Stream.Read(n, 2);
    for i := 0 to n - 1 do
    with q.frParams do
    begin
      Stream.Read(w, 2);
      ParamType[i] := ParamTypes[w];
      Stream.Read(w, 2);
      case w of
        0, $100: ParamKind[i] := pkAssignFromMaster;
        1:       ParamKind[i] := pkValue;
        $101:    ParamKind[i] := pkAsk;
      end;
      s := ReadString;
      if w = 1 then
        ParamText[i] := s;
    end;
  end;

  procedure ReadDataset1;
  var
    t: TfrTable;
    q: TfrQuery;
  begin
    Stream.Read(b, 1);
    if b = 0 then
    begin
      t := TfrTable.Create(frDataModule);
      t.Name := ReadString;
      t.frDatabaseName := ReadString;
      t.TableName := ReadString;
      t.IndexName := ReadString;
      t.Filter := ReadString;
      t.Filtered := t.Filter <> '';
      t.FieldDefs.Update;
      CreateDataSources(t);
    end
    else
    begin
      q := TfrQuery.Create(frDataModule);
      q.Name := ReadString;
      q.frDatabaseName := ReadString;
      frReadMemo(Stream, q.SQL);
      CreateDataSources(q);
    end;
  end;

  procedure ReadDataset2;
  var
    t: TfrTable;
    q: TfrQuery;
    ds: TDataset;
    s: String;
  begin
    Stream.Read(b, 1);
    s := ReadString;
    ds := frDataModule.FindComponent(s) as TDataset;
    if b = 0 then
    begin
      t := ds as TfrTable;
      s := ReadString;
      ds := frFindComponent(frDataModule, s) as TDataset;
      t.MasterSource := GetDataSource(ds);
      t.MasterFields := ReadString;
      ReadFields(t);
    end
    else
    begin
      q := ds as TfrQuery;
      s := ReadString;
      ds := frFindComponent(frDataModule, s) as TDataset;
      q.DataSource := GetDataSource(ds);
      ReadParams(q);
      q.FieldDefs.Update;
      ReadFields(q);
    end;
  end;

  procedure ReadDialogControls;
  var
    i: Integer;
    w: Word;
    p: PfrParamInfo;
    procedure ReadControlInfo(p: PfrControlInfo);
    begin
      with p^ do
      begin
        Stream.Read(Bounds, SizeOf(Bounds));
        Caption := ReadString;
        FontName := ReadString;
        Stream.Read(FontSize, 4);
        Stream.Read(FontStyle, 2);
        Stream.Read(FontCharset, 2);
        Stream.Read(FontColor, 4);
      end;
    end;
  begin
    Stream.Read(w, 2);
    Stream.Read(ParamFormWidth, 4);
    Stream.Read(ParamFormHeight, 4);
    for i := 0 to w - 1 do
    begin
      GetMem(p, SizeOf(TfrParamInfo));
      FillChar(p^, SizeOf(TfrParamInfo), #0);
      p^.ComboStrings := TStringList.Create;
      p^.QueryName := ReadString;
      p^.QueryRef := frFindComponent(nil, p^.QueryName) as TfrQuery;
      p^.ParamName := ReadString;
      ReadControlInfo(@p^.LabelControl);
      ReadControlInfo(@p^.EditControl);
      Stream.Read(p^.Typ, 1);
      if p.Typ = ptLookup then
      begin
        p^.LookupDS := ReadString;
        p^.LookupKF := ReadString;
        p^.LookupLF := ReadString;
      end
      else if p^.Typ = ptCombo then
        frReadMemo(Stream, p^.ComboStrings);
      frParamList.Add(p);
    end;
  end;

  procedure ReadSpecialParams;
  var
    i: Integer;
    w: Word;
    s: String;
  begin
    frSpecialParams.Clear;
    Stream.Read(w, 2);
    for i := 0 to w - 1 do
    begin
      s := ReadString;
      frSpecialParams[Copy(s, 1, Pos('=', s) - 1)] := Copy(s, Pos('=', s) + 1, 255);
    end;
  end;

  procedure ReadDatabases;
  var
    b: Byte;
    d: TfrDatabase;
  begin
    d := TfrDatabase.Create(frDataModule);
    d.Name := ReadString;
    d.frDriver := ReadString;
    Stream.Read(b, 1);
    d.LoginPrompt := Boolean(b);
    frReadMemo(Stream, sl);
    if d.Params <> nil then
      d.Params.Assign(sl);
    d.frDatabaseName := ReadString;
    d.Connected := True;
  end;

begin
  sl := TStringList.Create;
  Clear;

  Version23 := False;
  Stream.Read(n, 2);
  if n < 255 then
    Version23 := True;

  if not Version23 then
  begin
    Stream.Read(n, 2);
    for i := 0 to n - 1 do
      ReadDatabases;
    Stream.Read(n, 2);
  end;

  for i := 0 to n - 1 do
    ReadDataset1;
  for i := 0 to n - 1 do
    ReadDataset2;
  if n > 0 then
  begin
    ReadDialogControls;
    ReadSpecialParams;
  end;
  sl.Free;
end;

procedure TfrReportDataManager.SaveToStream(Stream: TStream);
var
  i: Integer;
  b: Byte;
  w: Word;
  sl: TStringList;