tmsuole2impl.pas

TMS Component Pack V5.0包含了超过 280 个为 Delphi 以及 C++Builder 设计的 TMS 生产控件

unit tmsUOle2Impl;
{$INCLUDE FLEXCEL.INC}

{$R+}
interface
uses Classes, tmsUFlxMessages, SysUtils, tmsXlsMessages, Contnrs,
     {$IFDEF FLX_GENERICS} Generics.Collections, {$ENDIF}
     tmsUXlsProtect;

type
  STGTY = (
    STGTY_INVALID = 0,
    STGTY_STORAGE = 1,
    STGTY_STREAM = 2,
    STGTY_LOCKBYTES = 3,
    STGTY_PROPERTY = 4,
    STGTY_ROOT = 5
  );

  DECOLOR = (
    DECOLOR_RED = 0,
    DECOLOR_BLACK = 1
  );

  {$IFDEF FLX_GENERICS}
  UInt32List = TList<UInt32>;
  {$ELSE}
  UInt32List = class
  private
    FList: TList;
    function GetItems(const i: integer): UInt32;
    procedure SetItems(const i: integer; const Value: UInt32);

    function GetCapacity: Int32;
    procedure SetCapacity(const Value: Int32);
    function GetCount: Int32;

  protected
    property Capacity: Int32 read GetCapacity write SetCapacity;

  public
    constructor Create;
    destructor Destroy; override;

    property Items[const i: integer]: UInt32 read GetItems write SetItems; default;
    procedure Add(const Item: UInt32);
    property Count: Int32 read GetCount;
  end;
  {$ENDIF}

  TOneDirEntry = class
  public
    Name: UTF16String;
    LeftSid: Int32;
    RightSid: Int32;
    ChildSid: Int32;

    Deleted: boolean;
    Color: DECOLOR;

    constructor Create(const aName: UTF16String; const aLeftSid, aRightSid, aChildSid: Int32; const aColor: DECOLOR);
  end;

  {$IFDEF FLX_GENERICS}
  TDirEntryList = TObjectList<TOneDirEntry>;
  {$ELSE}
  TDirEntryList = class
  private
    FList: TObjectList;
    function GetItems(const i: integer): TOneDirEntry;
    procedure SetItems(const i: integer; const Value: TOneDirEntry);
    function GetCount: Int32;

  protected
  public
    constructor Create;
    destructor Destroy; override;

    property Items[const i: integer]: TOneDirEntry read GetItems write SetItems; default;
    procedure Add(const Item: TOneDirEntry);
    property Count: Int32 read GetCount;
  end;
  {$ENDIF}

  StringArray = Array of UTF16String;

  /// <summary>
  /// Header sector. It has a fixed size of 512 bytes.
  /// On this implementation, we don't save the first 109 DIF entries, as they will be saved by the DIF Sector.
  /// </summary>
  TOle2Header = class
  private
    FileSignature: ByteArray;
    class function CompareArray(const a1: ByteArray; const a2: ByteArray; const length: Int32): Boolean;
    function Get_FuSectorShift(): Int32;
    function Get_FSectorSize(): UInt32;
    function Get_uMiniSectorShift(): Int32;
    function Get_MiniSectorSize(): UInt32;
    function Get_csectFat(): UInt32;
    procedure Set_csectFat(const value: UInt32);
    function Get_sectDirStart(): UInt32;
    procedure Set_sectDirStart(const value: UInt32);
    function Get_FulMiniSectorCutoff(): UInt32;
    function Get_sectMiniFatStart(): UInt32;
    procedure Set_sectMiniFatStart(const value: UInt32);
    function Get_csectMiniFat(): UInt32;
    procedure Set_csectMiniFat(const value: UInt32);
    function Get_sectDifStart(): UInt32;
    procedure Set_sectDifStart(const value: UInt32);
    function Get_csectDif(): UInt32;
    procedure Set_csectDif(const value: UInt32);
    property FuSectorShift: Int32 read Get_FuSectorShift;
    property FSectorSize: UInt32 read Get_FSectorSize;

  public
    NotXls97: Boolean;
    Data: ByteArray;
    StartOfs: Int64;
    SectorSize: UInt32;
    uSectorShift: Int32;
    ulMiniSectorCutoff: UInt32;

    /// <summary>
    /// Creates the Header reading the data from a stream.
    /// </summary>
    /// <param name="aStream"></param>
    /// <param name="AvoidExceptions"></param>
    constructor Create(const aStream: TStream; const AvoidExceptions: Boolean);

    procedure Save(const aStream: TStream);
    function uDIFEntryShift(): Int32;
    function SectToStPos(const Sect: Int64): Int64;overload;
    function SectToStPos(const Sect: Int64; const Ofs: Int64): Int64;overload;
    property uMiniSectorShift: Int32 read Get_uMiniSectorShift;
    property MiniSectorSize: UInt32 read Get_MiniSectorSize;
    property csectFat: UInt32 read Get_csectFat write Set_csectFat;
    property sectDirStart: UInt32 read Get_sectDirStart write Set_sectDirStart;
    property FulMiniSectorCutoff: UInt32 read Get_FulMiniSectorCutoff;
    property sectMiniFatStart: UInt32 read Get_sectMiniFatStart write Set_sectMiniFatStart;
    property csectMiniFat: UInt32 read Get_csectMiniFat write Set_csectMiniFat;
    property sectDifStart: UInt32 read Get_sectDifStart write Set_sectDifStart;
    property csectDif: UInt32 read Get_csectDif write Set_csectDif;
  end;


  /// <summary>
  /// FAT Table stored as a list of ints.
  /// </summary>
  TOle2FAT = class (UInt32List)
  private
    Header: TOle2Header;
    LastFindSectorOfs: Int64;
    LastFindSectorStart: Int64;
    LastFindSectorRes: Int64;

    /// <summary>
    /// Use Create() to create an instance. This way we avoid calling virtual methods on a constructor.
    /// </summary>
    constructor Create(); overload;
    procedure LoadDifSector(const data: ByteArray; const inipos: UInt32; const endpos: UInt32; const aStream: TStream);
    procedure LoadFatSector(const data: ByteArray);

  public

    /// <summary>
    /// Creates a FAT integer list from the data on a stream.
    /// We have to read the DIF to access the actual FAT sectors.
    /// </summary>
    /// <param name="aHeader">The header record</param>
    /// <param name="aStream">Stream to read the FAT. When null, an Empty FAT will be created.</param>
    constructor Create(const aHeader: TOle2Header; const aStream: TStream); overload;
    destructor Destroy; override;
    function uFATEntryShift(): Int32;
    function GetNextSector(const Sect: Int64): Int64;
    function FindSector(const StartSect: Int64; const SectOfs: Int64): Int64;
  end;


  /// <summary>
  /// MINIFAT Table stored as a list of ints.
  /// </summary>
  TOle2MiniFAT = class (UInt32List)
  private
    Header: TOle2Header;

    /// <summary>
    /// Use Create() to create an instance. This way we avoid calling virtual methods on a constructor.
    /// </summary>
    constructor Create(); overload;
    procedure LoadMiniFatSector(const data: ByteArray);

  public

    /// <summary>
    /// Creates a MiniFAT integer list from the data on a stream.
    /// </summary>
    /// <param name="aHeader"></param>
    /// <param name="aStream"></param>
    /// <param name="aFAT"></param>
    constructor Create(const aHeader: TOle2Header; const aStream: TStream; const aFAT: TOle2FAT); overload;
    function GetNextSector(const Sect: Int64): Int64;
    function FindSector(const StartSect: Int64; const SectOfs: Int64): Int64;
  end;


  /// <summary>
  /// A semi-sector containing 1 Directory entry.
  /// </summary>
  TOle2Directory = class
  private
    Data: ByteArray;
    function Get_NameSize(): Int32;
    procedure Set_NameSize(const value: Int32);
    function Get_Name(): UTF16String;
    procedure Set_Name(const value: UTF16String);
    function Get_ObjType(): STGTY;
    procedure Set_ObjType(const value: STGTY);
    function Get_SectStart(): Int64;
    procedure Set_SectStart(const value: Int64);
    function Get_xulSize(): Int64;
    procedure Set_xulSize(const value: Int64);

  public
    ulSize: Int64;
    constructor Create(const aData: ByteArray);
    procedure Save(const aStream: TStream);
    class function GetNameSize(const Data: ByteArray; const StartPos: Int32): Int32;
    class function GetName(const Data: ByteArray; const StartPos: Int32): UTF16String;
    class function GetType(const Data: ByteArray; const StartPos: Int32): STGTY;
    class function GetSectStart(const Data: ByteArray; const StartPos: Int32): Int64;
    class procedure SetSectStart(const Data: ByteArray; const StartPos: Int32; const value: Int64);
    class function GetSize(const Data: ByteArray; const StartPos: Int32): Int64;
    class procedure SetSize(const Data: ByteArray; const StartPos: Int32; const value: Int64);
    class procedure Clear(const Data: ByteArray; const StartPos: Int32);
    class function GetLeftSid(const Data: ByteArray; const StartPos: Int32): Int32;
    class procedure SetLeftSid(const Data: ByteArray; const StartPos: Int32; const value: Int32);
    class function GetRightSid(const Data: ByteArray; const StartPos: Int32): Int32;
    class procedure SetRightSid(const Data: ByteArray; const StartPos: Int32; const value: Int32);
    class function GetChildSid(const Data: ByteArray; const StartPos: Int32): Int32;
    class procedure SetChildSid(const Data: ByteArray; const StartPos: Int32; const value: Int32);
    class function GetColor(const Data: ByteArray; const StartPos: Int32): DECOLOR;
    class procedure SetColor(const Data: ByteArray; const StartPos: Int32; const value: DECOLOR);
    property NameSize: Int32 read Get_NameSize write Set_NameSize;
    property Name: UTF16String read Get_Name write Set_Name;
    property ObjType: STGTY read Get_ObjType write Set_ObjType;
    property SectStart: Int64 read Get_SectStart write Set_SectStart;
    property xulSize: Int64 read Get_xulSize write Set_xulSize;
  end;

  TSectorBuffer = class
  private
    Data: ByteArray;
    Changed: Boolean;
    FSectorId: Int64;
    Header: TOle2Header;
    DataStream: TStream;
  public
    constructor Create(const aHeader: TOle2Header; const aStream: TStream);
    procedure Load(const SectNo: Int64);
    procedure Save();
    procedure Read(const aBuffer: ByteArray; const BufferPos: Int64; out nRead: Int64; const StartPos: Int64; const Count: Int64; const SectorSize: Int64);
    procedure ReadMem(var aBuffer; const BufferPos: Int64; out nRead: Int64; const StartPos: Int64; const Count: Int64; const SectorSize: Int64);
    property SectorId: Int64 read FSectorId;
  end;


  /// <summary>
  /// Class encapsulating an OLE2 file. FAT is kept in memory, data is read/written from/to disk.
  /// </summary>
  TOle2File = class
  private
    FStream: TStream;
    Header: TOle2Header;
    FAT: TOle2FAT;
    MiniFAT: TOle2MiniFAT;
    SectorBuffer: TSectorBuffer;
    ROOT: TOle2Directory;
    FEncryption: TEncryptionData;
    TOle2FileStr: UTF16String;
    disposed: Boolean;
    DIR: TOle2Directory;
    StreamPos: Int64;
    PreparedForWrite: Boolean;
    DIRStartPos: Int64;
    procedure MarkDeleted(const i: Int32; const Result: TDirEntryList; const Level: Int32);
    class procedure DeleteNode(const Result: TDirEntryList; var ParentLeaf: Int32);
    procedure FixNode(const Result: TDirEntryList; var ParentNode: Int32);
    function ReadDirs(const DeletedStorages: StringArray; var PaintItBlack: Boolean): TDirEntryList;
    procedure FinishStream();
    function Get_Length(): Int64;
    function Get_Position(): Int64;
    function Get_Eof(): Boolean;
    function Get_FileName(): UTF16String;

  public
    NotXls97: Boolean;

    /// <summary>
    /// Opens an EXISTING OLE2 Stream. There is no support for creating a new one, you can only modify existing ones.
    /// </summary>
    /// <param name="aStream">The stream with the data</param>
    constructor Create(const aStream: TStream);overload;

    /// <summary>
    /// Opens an EXISTING OLE2 Stream, without throwing an exception if it is a wrong file. (On this case the error is logged into the Notxls97 variable)
    /// There is no support for creating a new one, you can only modify existing ones.
    /// </summary>
    /// <param name="aStream">The stream with the data</param>
    /// <param name="AvoidExceptions">If true, no Exception will be raised when the file is not OLE2.</param>
    constructor Create(const aStream: TStream; const AvoidExceptions: Boolean);overload;

    destructor Destroy; override;

    procedure Close();
    function FindDir(const DirName: UTF16String): TOle2Directory;
    function FindRoot(): TOle2Directory;
    procedure SelectStream(const StreamName: UTF16String);
    function NextEof(const Count: Int32): Boolean;

    procedure ReadMem(var aBuffer; const Count: Int32);
    /// <summary>
    /// Writes to the stream sequentially. No seek or read allowed while writing.
    /// </summary>
    /// <param name="Buffer">The data.</param>
    /// <param name="Count">number of bytes to write.</param>
    procedure WriteRawMem(const Buffer; const Count: Int32);overload;
    procedure WriteMem(const Buffer; const Count: Int32);overload;

    procedure Read(const aBuffer: ByteArray; const Count: Int32);
    procedure WriteRaw(const Buffer: ByteArray; const Count: Int32);overload;
    procedure Write(Buffer: ByteArray; const Count: Int32);overload;


    procedure WriteRaw(const Buffer: ByteArray; const StartPos: Int32; const Count: Int32);overload;
    procedure WriteHeader(const Id: UInt16; const Len: UInt16);
    procedure Write(Buffer: ByteArray; const StartPos: Int32; const Count: Int32);overload;
    procedure Write16(Buffer: UInt16);
    procedure Write32(Buffer: UInt32);
    class function FindString(const s: UTF16String; const list: StringArray): Boolean;

    /// <summary>
    /// Only seeks forward, no reverse. Not really optimized either, don't use in heavy places.
    /// </summary>
    /// <param name="Offset"></param>
    /// <returns></returns>
    procedure SeekForward(const Offset: Int64);

    /// <summary>
    /// This method copies the contents of the ole stream to a new one, and clears the OStreamName
    /// stream, leaving it ready to be written.
    /// </summary>
    /// <param name="OutStream">The new Stream where we will write the data</param>
    /// <param name="OStreamName">Ole Stream Name (tipically "Workbook") that we will clear to write the new data.</param>
    /// <param name="DeleteStorages">Storages we are not going to copy to the new one. Used to remove macros.</param>
    procedure PrepareForWrite(const OutStream: TStream; const OStreamName: UTF16String; const DeleteStorages: StringArray);
    property Encryption: TEncryptionData read FEncryption;
    property Length: Int64 read Get_Length;
    property Position: Int64 read Get_Position;
    property Eof: Boolean read Get_Eof;
    property FileName: UTF16String read Get_FileName;
  end;


implementation
{.$region 'Constants'}
const
    TOle2Header_HeaderSize = 512;
   (*
    * OLE2 File format implementation.
	  * This file is used by UOLE2Stream to provide an uniform access layer to OLE2 Compound documents.
	  * Honoring flexcel tradition, this file is targeted to be "one" api to modify, instead of "two" apis, one for read and one for write.
	  *)

  //This is fixed on the header sector.
    TOle2Header_DifsInHeader: Int32  = 109;
    TOle2Header_DifEntries: Int32  = 436;  //Difs don't really belong here.
    TOle2Header_ENDOFCHAIN: UInt32  = 4294967294;
    TOle2Header_DIFSECT: UInt32  = 4294967292;
    TOle2Header_FATSECT: UInt32  = 4294967293;
    TOle2Header_FREESECT: UInt32 = 4294967295;
    TOle2Directory_DirectorySize = 128;
{.$endregion}

procedure StreamRead(const aStream: TStream; const aData: ByteArray; const IniOfs, Count: integer; ThrowOnEOF: boolean);
var
  BytesRead: integer;
  i: integer;
begin
  if (ThrowOnEOF) then aStream.ReadBuffer(aData[IniOfs], Count)
  else
  begin
    BytesRead := aStream.Read(aData[IniOfs], Count);
    if BytesRead < Count then
    begin
      for i := BytesRead to Count - 1 do aData[IniOfs + i] := 0;
    end;
  end;
end;


{.$region 'TOle2Header'}
{ TOle2Header }
constructor TOle2Header.Create(const aStream: TStream; const AvoidExceptions: Boolean);
begin
  inherited Create;
  //Initializations
  SetLength (FileSignature, 8);
  FileSignature[0] := 208;
  FileSignature[1] := 207;