Chip 2002 October/Chip_2002-10_cd1.bin/zkuste/delphi/kolekce/d56/FLEXCEL.ZIP/XLSAdapter/TemplateStore.pas

Pascal/Delphi Source File | 2002-07-03 | 11KB | 455 lines

unit TemplateStore;

interface
{$R XLSTemplateStore.res}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, contnrs,
  axctrls, activex, ComObj, XlsMessages, UXlsOLEDoc;

type
  TXlsStorageList=class;

  TXlsStorage = class
  private
    FCompress: boolean;
    procedure SetCompress(const Value: boolean);
  public
    Name: string;
    Data: TMemoryStream;
    SubStorages: TXlsStorageList;

    property Compress: boolean read FCompress write SetCompress;

    constructor Create;
    destructor Destroy;override;

    procedure WriteData(Stream: TStream);
    procedure ReadData(Stream: TStream);

    procedure SaveToDoc( const DocOUT: IStorage);
  end;

  TXlsStorageList=class(TObjectList)
    Compress: boolean;
    procedure WriteData(Stream: TStream);
    procedure ReadData(Stream: TStream);
    procedure LoadFrom(const aFileName: TFileName);
  private
    procedure LoadStorage(const DocIN: IStorage);
    function GetItems(index: integer): TXlsStorage;
    function GetStream(Name: widestring): TStream;
  public
    property Items[index: integer]: TXlsStorage read GetItems; default;
    property Stream[Name: widestring]: TStream read GetStream;
  end;

  TXlsTemplate= class (TCollectionItem)
  private
    FStorages: TXlsStorageList;
    FFileName: TFileName;
    FCompress: boolean;

    procedure SetFileName(const Value: TFileName);
    procedure SetCompress(const Value: boolean);

    property Compress: boolean read FCompress write SetCompress;
  protected
    function GetDisplayName: string; override;
    procedure SetDisplayName(const Value: string); override;

    procedure WriteData(Stream: TStream);
    procedure ReadData(Stream: TStream);
    procedure DefineProperties(Filer: TFiler); override;
    function Equal(aTemplate: TXlsTemplate): Boolean;
  public

    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    property Storages: TXlsStorageList read FStorages;
  published
    property FileName: TFileName read FFileName write SetFileName stored false;
  end;

  TXlsTemplateList=class(TOwnedCollection) //Items are TXlsTemplate
  private
    FCompress: boolean;
    procedure SetCompress(const Value: boolean);
    property Compress: boolean read FCompress write SetCompress;
    function GetItems(Index: integer): TXlsTemplate;
  public
    property Items[Index: integer]: TXlsTemplate read GetItems; default;
  end;

  TXlsTemplateStore = class(TComponent)
  private
    FCompress: boolean;
    procedure SetCompress(const Value: boolean);
    function GetStorages(Name: String): TXlsStorageList;
    { Private declarations }
  protected
    FTemplates: TXlsTemplateList;
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;override;
    property Storages[Name: String]: TXlsStorageList read GetStorages;
  published
    { Published declarations }
    property Templates: TXlsTemplateList read FTemplates write FTemplates;
    property Compress: boolean read FCompress write SetCompress;


    //PENDING:AssignTo
  end;

procedure Register;

implementation
procedure Register;
begin
  RegisterComponents('FlexCel', [TXlsTemplateStore]);
end;

{ TXlsStorageList }

constructor TXlsStorage.Create;
begin
  inherited Create;
  Data:= TMemoryStream.Create;
  SubStorages:= TXlsStorageList.Create;
end;

destructor TXlsStorage.Destroy;
begin
  FreeandNil(Data);
  FreeAndNil(SubStorages);
  inherited;
end;

procedure TXlsStorage.ReadData(Stream: TStream);
var
  Ds: integer;
begin
  Stream.ReadBuffer(Ds, SizeOf(Ds));
  SetLength(Name, Ds);
  Stream.ReadBuffer(Name[1], Ds);
  Stream.ReadBuffer(Ds, SizeOf(Ds));
  Data.Size:=Ds;
  Data.Position:=0;
  Stream.Read(Data.Memory^, Ds);
  SubStorages.ReadData(Stream);
end;

procedure TXlsStorage.SaveToDoc(const DocOUT: IStorage);
var
  StreamOUT: IStream;
  NewDocOUT: IStorage;
  nw: Longint;
  i:integer;
  WideName: WideString;
begin
  WideName:=Name;
  if Data.Size> 0 then
  begin
    OleCheck(DocOUT.CreateStream(PWideChar(WideName), OptionsWrite, 0, 0, StreamOUT));
    try
      OleCheck(StreamOUT.Write(Data.Memory, Data.Size, @nw));
    finally
      StreamOut:=nil;
    end;
  end else
  if SubStorages.Count>0 then
  begin
    OleCheck(DocOUT.CreateStorage(PWideChar(WideName), OptionsWrite, 0, 0, NewDocOUT));
    try
      for i:=0 to SubStorages.Count-1 do (SubStorages[i] as TXlsStorage).SaveToDoc(NewDocOUT);
    finally
      NewDocOUT:=nil;
    end;
  end;
end;

procedure TXlsStorage.SetCompress(const Value: boolean);
begin
  FCompress := Value;
  SubStorages.Compress:=Value;
end;

procedure TXlsStorage.WriteData(Stream: TStream);
var
  Ln: integer;
begin
  Ln:=Length(Name);
  Stream.WriteBuffer(Ln, SizeOf(Ln));
  Stream.WriteBuffer(Name[1], Ln);
  Ln:=Data.Size;
  Stream.WriteBuffer(Ln, SizeOf(Ln));
  Data.Position:=0;
  Stream.Write(Data.Memory^, Data.Size);
  SubStorages.WriteData(Stream);
end;

{ TXlsStorageList }

procedure TXlsStorageList.LoadStorage(const DocIN: IStorage);
var
  NewDocIN: IStorage;
  Enum: IEnumStatStg;
  NumFetched: integer;
  StatStg: TStatStg;
  StreamIN: IStream;
  OleStreamIn: TOleStream;
  Malloc: IMalloc;
  Stor: TXlsStorage;
  //PENDING: Compress: TCompressionStream;

begin
  OleCheck(CoGetMalloc(1, Malloc));
  if DocIN.EnumElements(0, nil, 0, Enum) <> S_OK then
  begin
    DocIN.Stat(StatStg, 0);
    try
      raise Exception.CreateFmt(ErrCantReadFile, [StatStg.pwcsName]);
    finally
      Malloc.Free(StatStg.pwcsName);
    end; //finally
  end;

  while Enum.Next(1, StatStg, @NumFetched) = S_OK do
  begin
  try
    case StatStg.dwType of
      STGTY_STREAM:
        begin
          OleCheck(DocIN.OpenStream(StatStg.pwcsName, nil, OptionsRead, 0, StreamIN));
          try
            OleStreamIn:= TOleStream.Create(StreamIn);
            try
              Stor:=(Items[Add(TXlsStorage.Create)] as TXlsStorage);
              try
//                Compress:= TCompressionStream.Create(clMax, Stor.Data);
//                Compress.CopyFrom(OleStreamIn, OleStreamIn.Size);
                Stor.Data.CopyFrom(OleStreamIn, OleStreamIn.Size);
              finally
//                FreeAndNil(Compress);
              end; //finally
              Stor.Name:=StatStg.pwcsName;
            finally
              FreeAndNil(OleStreamIn);
            end; //finally
          finally
            StreamIN := nil;
          end; //finally
        end;

      STGTY_STORAGE:
        begin
          OleCheck(DocIN.OpenStorage(StatStg.pwcsName, nil, OptionsRead, nil, 0, NewDocIN));
          try
            Stor:=(Items[Add(TXlsStorage.Create)] as TXlsStorage);
            Stor.Name:=StatStg.pwcsName;
            Stor.SubStorages.LoadStorage(NewDocIN);
          finally
            NewDocIN := nil;
          end; //finally
        end;
    end; //case
  finally
     Malloc.Free(StatStg.pwcsName);
  end; //finally
  end; //while

end;

procedure TXlsStorageList.LoadFrom(const aFileName: TFileName);
var
  WideFileName: WideString;
  DocIN: IStorage;
begin
  Clear;
  //Open template
  WideFileName:=aFileName;

  if StgIsStorageFile(PWideChar(WideFileName)) <> S_OK then
      raise Exception.CreateFmt(ErrFileIsNotXLS, [WideFileName]);

  OleCheck(StgOpenStorage(PWideChar(WideFileName), nil, OptionsRead, nil, 0, DocIN));
  try
    LoadStorage(DocIN);
  finally
    DocIN:=nil;
  end;
end;

procedure TXlsStorageList.ReadData(Stream: TStream);
var
  Cnt, i: integer;
begin
  Stream.Read(Cnt, sizeOf(Cnt));
  Clear;
  for i:=0 to Cnt-1 do
   (Items[Add(TXlsStorage.Create)]as TXlsStorage).ReadData(Stream);
end;

procedure TXlsStorageList.WriteData(Stream: TStream);
var
  i:integer;
begin
  Stream.Write(Count, SizeOf(Count));
  for i:=0 to Count-1 do
   (Items[i]as TXlsStorage).WriteData(Stream);
end;

function TXlsStorageList.GetItems(index: integer): TXlsStorage;
begin
  Result:=inherited Items[index] as TXlsStorage;
end;

function TXlsStorageList.GetStream(Name: widestring): TStream;
var
  i:integer;
begin
  for i:=0 to Count-1 do if Items[i].Name=Name then
  begin
    Result:= Items[i].Data;
    exit;
  end;
  raise Exception.CreateFmt(ErrStreamNotFound,[Name]);
end;

{ TXlsTemplate }

constructor TXlsTemplate.Create(Collection: TCollection);
begin
  inherited;
  FStorages:=TXlsStorageList.Create;
end;

procedure TXlsTemplate.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
      Result := not (Filer.Ancestor is TXlsTemplate) or
        not Equal(TXlsTemplate(Filer.Ancestor))
    else
      Result := FFileName<>'';
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('TemplateData', ReadData, WriteData, DoWrite);
end;

destructor TXlsTemplate.Destroy;
begin
  FreeAndNil(FStorages);
  inherited;
end;

function TXlsTemplate.Equal(aTemplate: TXlsTemplate): Boolean;
begin
  Result:=FFileName=aTemplate.FFileName;
end;

function TXlsTemplate.GetDisplayName: string;
begin
  Result:=FFileName;
end;

procedure TXlsTemplate.ReadData(Stream: TStream);
var
  Version: SmallInt;
  Ln: integer;
begin
  Stream.ReadBuffer(Version, SizeOf(Version));
  Stream.ReadBuffer(Ln, SizeOF(Ln));
  SetLength(FFileName, Ln);
  Stream.ReadBuffer(FFileName[1], Ln);
  FStorages.ReadData(Stream);
end;

procedure TXlsTemplate.SetCompress(const Value: boolean);
var
  i:integer;
begin
  FCompress := Value;
  for i:=0 to FStorages.Count-1 do FStorages[i].Compress:=Value;
end;

procedure TXlsTemplate.SetDisplayName(const Value: string);
begin
  inherited;
  FileName:=Value;
end;

procedure TXlsTemplate.SetFileName(const Value: TFileName);
begin
  FStorages.LoadFrom(Value);
  FFileName := ExtractFileName(Value);
end;

procedure TXlsTemplate.WriteData(Stream: TStream);
var
  Version: SmallInt;
  Ln: integer;
begin
  Version:=1;
  Stream.WriteBuffer(Version,SizeOf(Version));
  Ln:=Length(FFileName);
  Stream.WriteBuffer(Ln, SizeOf(Ln));
  Stream.WriteBuffer(FFileName[1], Ln);
  FStorages.WriteData(Stream);
end;

{ TXlsTemplateStore }

constructor TXlsTemplateStore.Create(AOwner: TComponent);
begin
  inherited;
  FTemplates:= TXlsTemplateList.Create(Self, TXlsTemplate);
end;

destructor TXlsTemplateStore.Destroy;
begin
  FreeAndNil(FTemplates);
  inherited;
end;

function TXlsTemplateStore.GetStorages(Name: String): TXlsStorageList;
var
  i: integer;
begin
  Name:= ExtractFileName(Name);
  for i:=0 to Templates.Count -1 do if Templates[i].FileName=Name then
  begin
    Result:=Templates[i].Storages;
    exit;
  end;
  raise Exception.CreateFmt(ErrFileNotFound, [Name]);
end;

procedure TXlsTemplateStore.SetCompress(const Value: boolean);
begin
  FCompress := Value;
  Templates.Compress:=Value;
end;

{ TXlsTemplateList }

function TXlsTemplateList.GetItems(Index: integer): TXlsTemplate;
begin
  Result:= inherited Items[Index] as TXlsTemplate;
end;

procedure TXlsTemplateList.SetCompress(const Value: boolean);
var
  i:integer;
begin
  FCompress := Value;
  for i:=0 to Count-1 do Items[i].Compress:=true;
end;

end.