flatexcel.pas

comerose_flatstyle_v4.42.9.0_d7.rar

{
   功能：将数据集的数据导入Excel;
   作者：comerose (核心代码来自Ehlib)
   时间：2006-06-25
}                  

unit FlatExcel;

{$I FlatStyle.inc}

interface

uses
 Controls, Forms, SysUtils, DB, DBCtrls, DBGrids, Classes, DBConsts,
 Grids, FlatExcfm, FlatUtils, Dialogs;

type
  //导出数据选项,
  //dmDefault为导出的数据默认为字段类型的数据,
  //dmString为导出的所有数据全部转换为字符类型
  TEduceType  = (dmDefault,dmString);
  TEduceMode  = (emDefault,emSingle);
  TEduceData  = class;
  TEduceDatas = class;
  TEduceLink  = class;
  { TDefineExcel }
  TDefineExcel  = Class(TVersionComponent)
  Private
    fCol        : word;
    fRow        : word;
    ExcelStream : TStream;
    FEduceType  : TEduceType;
    FColumns    : TEduceDatas;
    FUpdateLock : Byte;
    FLayoutLock : Byte;
    FDataLink   : TEduceLink;
    FLayoutSet  : Boolean;
    FEduceTitle : Boolean;
    FExcelForm  : TExcelForm;
    FInterval   : integer;
    FShowProgress: boolean;
    FFileName: String;
    FEduceMode: TEduceMode;
    FDefaultExt: String;
    function  GetFieldCount: Integer;
    function  GetDataSource: TDataSource;
    function  GetColumnCount: integer;
    function  GetEduceCount: integer;
    procedure SeTEduceType(const Value: TEduceType);
    procedure EndProgress;
    procedure StartProgress(Max: Integer);
    procedure SetColumns(const Value: TEduceDatas);
    procedure SetDataSource(const Value: TDataSource);
    procedure DefineFieldMap;
    function  GetFields(FieldIndex: Integer): TField;
    procedure SetDefaultExt(Value: String);
  protected
    // 以下是导出到 MS-Excel 操作过程
    procedure WriteData(Field: TField);
    procedure WriteTitle;
    procedure WriteBlankCell;
    procedure WriteFloatCell(const AValue: Double);
    procedure WriteIntegerCell(const AValue: Integer);
    procedure WriteStringCell(const AValue: string);
    procedure WritePrefix;
    procedure WriteSuffix;
    procedure WriteDataCells;
    procedure SaveExcel(Save: TStream);
    // 结束 MS-Excel 操作过程
    procedure BeginLayout;
    procedure EndLayout;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure LayoutChanged; virtual;
    procedure LinkActive(Value: Boolean); virtual;
    procedure CancelLayout;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadColumns(Reader: TReader);
    procedure WriteColumns(Writer: TWriter);
    procedure Loaded; override;
    procedure InitColumns;
    procedure IncColRow;
    function  CreateDataLink: TEduceLink; dynamic;
    function  CreateColumns: TEduceDatas;
    function  AcquireLayoutLock: Boolean;
    property  UpdateLock: Byte read FUpdateLock;
    property  LayoutLock: Byte read FLayoutLock;
    property  DataLink: TEduceLink read FDataLink;
    property  LayoutSet: Boolean read FLayoutSet write FLayoutSet;
    property  EduceType: TEduceType read FEduceType write SeTEduceType default dmDefault;
    property  EduceDatas: TEduceDatas read FColumns write SetColumns;
    property  DataSource: TDataSource read GetDataSource write SetDataSource;
    property  EduceTitle: Boolean read FEduceTitle write FEduceTitle default true;
    property  ExcelForm: TExcelForm read FExcelForm;
    property  Interval: integer read FInterval write FInterval default 500;
    property  ShowProgress: boolean read FShowProgress write FShowProgress default true;
    property  FileName: String read FFileName write FFileName;
    property  EduceMode: TEduceMode read FEduceMode write FEduceMode default emSingle;
    property  DefaultExt: String read FDefaultExt write SetDefaultExt;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExportAll;
    procedure ExecuteSave;

    procedure InitFields;
    procedure RestoreFields;
    procedure ClearFields;
    property  Fields[FieldIndex: Integer]: TField read GetFields;
    property  FieldCount: Integer read GetFieldCount;
    property  ColumnCount: integer read GetColumnCount;
    property  EduceCount: integer read GetEduceCount;
  end;
  { FlatExcel }
  TFlatExcel  = Class(TDefineExcel)
  published
    property  EduceType;
    property  EduceDatas stored False;
    property  DataSource;
    property  EduceTitle;
    property  Interval;
    property  ShowProgress;
    property  FileName;
    property  EduceMode;
    property  DefaultExt;
  end;
  { TEduceLink }
  TEduceLink = class(TDataLink)
  private
    FCells: TDefineExcel;
    FFieldCount: Integer;
    FFieldMap: array of Integer;
    FModified: Boolean;
    FSparseMap: Boolean;
    function GetDefaultFields: Boolean;
    function GetFields(I: Integer): TField;
  protected
    procedure ActiveChanged; override;
    procedure LayoutChanged; override;
    function  GetMappedIndex(ColIndex: Integer): Integer;
    function  IsAggRow(Value: Integer): Boolean; virtual;
  public
    constructor Create(ADSExcel: TDefineExcel);
    destructor Destroy; override;
    procedure ClearMapping;
    function AddMapping(const FieldName: string): Boolean;
    property DefaultFields: Boolean read GetDefaultFields;
    property FieldCount: Integer read FFieldCount;
    property Fields[I: Integer]: TField read GetFields;
    property SparseMap: Boolean read FSparseMap write FSparseMap;
    property Cells: TDefineExcel read FCells;
  end;
  { TEduceData }
  TEduceData = class(TCollectionItem)
  private
    FFieldName: string;
    FVisible: Boolean;
    FStored: Boolean;
    FCaption: String;
    FField: TField;
    procedure SetCaption(const Value: String);
    procedure SetField(Value: TField);
    function  GetField: TField;
    procedure SetFieldName(const Value: String);
    procedure SetVisible(const Value: Boolean);
  protected
    function  GetExcel: TDefineExcel;
    function  GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property  Cells: TDefineExcel read GetExcel;
    property  Field: TField read GetField write SetField;
    property  IsStored: Boolean read FStored write FStored default false;
  published
    property  Caption: string read fCaption write SetCaption;
    property  FieldName: String read fFieldName write SetFieldName;
    property  Visible: Boolean read FVisible write SetVisible;
  end;
  TEduceDataClass = class of TEduceData;
  TEduceDatasState = (csDefault, csCustomized);
  { TEduceDatas }
  TEduceDatas = class(TCollection)
  private
    FCells: TDefineExcel;
    function  GetColumn(Index: Integer): TEduceData;
    function  GetState: TEduceDatasState;
    procedure SetColumn(Index: Integer; Value: TEduceData);
    procedure SetState(NewState: TEduceDatasState);
  protected
    function  GetOwner: TPersistent; override;
    function  InternalAdd: TEduceData;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(DSExcel: TDefineExcel; ColumnClass: TEduceDataClass);
    procedure LoadFromFile(const Filename: string);
    procedure LoadFromStream(S: TStream);
    procedure RebuildColumns;
    procedure SaveToFile(const Filename: string);
    procedure SaveToStream(S: TStream);
    function  Add: TEduceData;
    property  State: TEduceDatasState read GetState write SetState;
    property  Cells: TDefineExcel read FCells;
    property  Items[Index: Integer]: TEduceData read GetColumn write SetColumn; default;
  end;

implementation

uses FlatExcpt;

{ Error reporting }

procedure RaiseGridError(const S: string);
begin
  raise EInvalidGridOperation.Create(S);
end;

{ TEduceData }

constructor TEduceData.Create(Collection: TCollection);
var
  Excel: TDefineExcel;
begin
  Excel := nil;
  if Assigned(Collection) and (Collection is TEduceDatas) then
     Excel := TEduceDatas(Collection).Cells;
  if Assigned(Excel) then Excel.BeginLayout;
  try
   inherited Create(Collection);
   FVisible  := True;
   FStored   := True;
  finally
   if Assigned(Excel) then Excel.EndLayout;
  end;
end;

destructor TEduceData.Destroy;
begin
  inherited Destroy;
end;

procedure TEduceData.Assign(Source: TPersistent);
begin
  if Source is TEduceData then
  begin
    if Assigned(Collection) then Collection.BeginUpdate;
    try
      FieldName := TEduceData(Source).FieldName;
      FCaption  := TEduceData(Source).Caption;
      FVisible  := TEduceData(Source).Visible;
      Changed(false);
    finally
      if Assigned(Collection) then Collection.EndUpdate;
    end;
  end else inherited Assign(Source);
end;

function TEduceData.GetExcel: TDefineExcel;
begin
  if Assigned(Collection) and (Collection is TEduceDatas) then
     Result := TEduceDatas(Collection).Cells
  else
     Result := nil;
end;

function TEduceData.GetDisplayName: string;
begin
  Result := FCaption;
  if Result = '' then
     Result := inherited GetDisplayName;
end;

procedure TEduceData.SetCaption(const Value: String);
begin
  if (Value <> FCaption) then
  begin
     FCaption := Value;
     Changed(false);
  end;
end;  

procedure TEduceData.SetField(Value: TField);
begin
  if FField = Value then Exit;
  if Assigned(FField) and (GetExcel <> nil) then
     FField.RemoveFreeNotification(GetExcel);
  if Assigned(Value) and (csDestroying in Value.ComponentState) then
     Value := nil;
  FField := Value;
  if Assigned(Value) then
  begin
    if GetExcel <> nil then
       FField.FreeNotification(GetExcel);
    FFieldName := Value.FullName;
    if (Length(FCaption)=0) and (Length(FieldName) > 0) then
    begin
       if Value.DisplayLabel = '' then
          FCaption := Value.FullName
       else
          FCaption := Value.DisplayLabel;
    end;
  end;
  if not IsStored then
  begin
    if Value = nil then
       FFieldName := '';
  end;
  Changed(False);
end;

function TEduceData.GetField: TField;
var
  Cell: TDefineExcel;
begin
  Cell := GetExcel;
  if (FField = nil) and (Length(FFieldName) > 0) and Assigned(Cell) and
      Assigned(Cell.DataLink.DataSet) then
  begin
  with Cell.Datalink.Dataset do
    if Active or (not DefaultFields) then
       SetField(FindField(FieldName));
  end;
  Result := FField;
end;

procedure TEduceData.SetFieldName(const Value: String);
var
  AField: TField;
  Cells: TDefineExcel;
begin
  AField := nil;
  Cells := GetExcel;
  if Assigned(Cells) and Assigned(Cells.DataLink.DataSet) and
    not (csLoading in Cells.ComponentState) and (Length(Value) > 0) then
      AField := Cells.DataLink.DataSet.FindField(Value); { no exceptions }
  FFieldName := Value;
  SetField(AField);
  Changed(False);
end;

procedure TEduceData.SetVisible(const Value: Boolean);
begin
  if Value <> FVisible then
  begin
     FVisible := Value;
     Changed(false);
  end;
end;

{ TEduceDatas }

constructor TEduceDatas.Create(DSExcel: TDefineExcel; ColumnClass: TEduceDataClass);
begin
  inherited Create(ColumnClass);
  FCells := DSExcel;
end;

function TEduceDatas.Add: TEduceData;
begin
  Result := TEduceData(inherited Add);
end;

function TEduceDatas.GetColumn(Index: Integer): TEduceData;
begin
  Result := TEduceData(inherited Items[Index]);
end;

function TEduceDatas.GetOwner: TPersistent;
begin
  Result := FCells;
end;

procedure TEduceDatas.LoadFromFile(const Filename: string);
var
  S: TFileStream;
begin
  S := TFileStream.Create(Filename, fmOpenRead);
  try
    LoadFromStream(S);
  finally
    S.Free;
  end;
end;

{ TEduceWrapper }
type
  TEduceWrapper = class(TComponent)
  private
    FColumns: TEduceDatas;
  published
    property Columns: TEduceDatas read FColumns write FColumns;
  end;

procedure TEduceDatas.LoadFromStream(S: TStream);
var
  Wrapper: TEduceWrapper;
begin
  Wrapper := TEduceWrapper.Create(nil);
  try
    Wrapper.Columns := FCells.CreateColumns;
    S.ReadComponent(Wrapper);
    Assign(Wrapper.Columns);
  finally
    Wrapper.Columns.Free;
    Wrapper.Free;
  end;
end;

procedure TEduceDatas.RebuildColumns;

  procedure AddFields(Fields: TFields; Depth: Integer);
  var
    I: Integer;
  begin
    Inc(Depth);
    for I := 0 to Fields.Count-1 do
    begin
      Add.FieldName := Fields[I].FullName;
      if Fields[I].DataType in [ftADT, ftArray] then
         AddFields((Fields[I] as TObjectField).Fields, Depth);
    end;
  end;

begin
  if Assigned(FCells) and Assigned(FCells.DataSource) and
     Assigned(FCells.Datasource.DataSet) then
  begin