xlsstream2.pas

一个经典的读写Excel的控件

unit XLSStream2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}

interface

uses SysUtils, Classes, BIFFRecsII2, Windows, ComObj, ActiveX, Math, XLS_MD5,
     XLSRWIIResourceStrings2, XLSUtils2, XLS_RC4;

type PExtraData = ^TExtraData;
     TExtraData = record
     Name: PWideChar;
     LockBytes: ILockBytes;
     Storage: IStorage;
     end;

type PExtraStreamData = ^TExtraStreamData;
     TExtraStreamData = record
     Name: PWideChar;
     Size: integer;
     Data: PByteArray;
     end;

type TExtraObjects = class(TList)
private
     FStreams: TList;

     function GetItems(Index: integer): PExtraData;
public
     constructor Create;
     destructor Destroy; override;
     procedure Add(Name: PWideChar; LockBytes: ILockBytes; Storage: IStorage);
     procedure AddStream(Name: PWideChar; Size: integer);
     procedure ReadStreams(Storage: IStorage);
     procedure WriteStreams(Storage: IStorage);
     procedure Clear; override;

     property Items[Index: integer]: PExtraData read GetItems; default;
     end;

type TXLSStream = class(TObject)
private
     OleStorage: IStorage;
     OleStream: IStream;
     FStream: TStream;
     FTargetStream: TStream;
     FSourceStream: TStream;
     FLockBytes: ILockBytes;
     FStreamSize: integer;
     FWrittenBytes: integer;
     FWriteCONTINUEPos: integer;
     FReadCONTINUEPos: integer;
     FReadCONTINUEActive: boolean;
     FMaxBytesWrite: integer;
     FExtraObjects: TExtraObjects;
     FSaveVBA: boolean;
     FISAPIRead: boolean;
     FIsEncrypted: boolean;
     FMD5Ctx: TMD5Context;
     FRC4Key: TRC4Key;
     FNextReKeyBlock: integer;

     function OpenOleStreamRead(Filename: PWideChar): TExcelVersion;
     function OpenFileStreamRead(const Filename: string): TExcelVersion;
     function IntWrite(const Buffer; Count: Longint): longint;
     procedure WriteStorageToDestStream;
     procedure ReadVBA(Name: PWideChar);
     procedure MakeKey(Block: longword; ctxVal: TMD5Context; var Key: TRC4Key);
     function  VerifyPassword(FILEPASS: PRecFILEPASS; Password: WideString): boolean;
     procedure CreatePassword(FILEPASS: PRecFILEPASS; Password: WideString);
     procedure EncryptSkipBytes(Start,Count: integer);
public
     constructor Create;
     destructor Destroy; override;
     function  OpenRead(const Filename: WideString): TExcelVersion;
     procedure OpenWrite(const Filename: WideString; Version: TExcelVersion);
     function  Read(var Buffer; Count: Longint): longint;
     function  ReadUnencrypted(var Buffer; Count: Longint): longint;
     function  ReadHeader(var Header: TBIFFHeader): integer;
     function  PeekHeader: word;
     function  Write(const Buffer; Count: Longint): longint;
     procedure WriteCONTINUE(RecId: word; const Buffer; Count: Longint);
     procedure WriteHeader(RecId: word; Length: word);
     procedure WriteBufHeader(const Buffer; RecId: word; Length: word);
     procedure WriteWord(RecId: word; Value: word);
     procedure WLWord(Value: longword);
     procedure WWord(Value: word);
     procedure WByte(Value: byte);
     procedure WriteUnicodeStr16(Value: string);
     procedure WriteUnicodeStr8(Value: string);
     procedure WriteWideString(Value: WideString);
     procedure WriteCellArea(Area: TRecCellArea);
     function  ReadWideString(Length: integer; var Str: WideString): integer;
     function  Seek(Offset: Longint; Origin: Word): longint;
     function  Seek3(Offset: Longint; Origin: Word): longint;
     function  Pos: longint;
     procedure BeginCONTINUEWrite(MaxRecSize: integer);
     procedure CheckCONTINUEWrite(const Buffer; Count: Longint);
     procedure EndCONTINUEWrite;
     procedure BeginCONTINUERead;
     procedure EndCONTINUERead;
     procedure WriteVBA;
     function  SetReadDecrypt(FILEPASS: PRecFILEPASS; Password: WideString): boolean;
     procedure Decrypt(Buffer: PByteArray; Count: integer);
     procedure Close;
     procedure EncryptFile(Password: WideString);
     // For debugging
     procedure WriteFile(RecId,Length: word; Filename: string);

     property  Size: integer read FStreamSize;
     property  WrittenBytes: integer read FWrittenBytes write FWrittenBytes;
     property  TargetStream: TStream read FTargetStream write FTargetStream;
     property  SourceStream: TStream read FSourceStream write FSourceStream;
     property  SaveVBA: boolean read FSaveVBA write FSaveVBA;
     property  ISAPIRead: boolean read FISAPIRead write FISAPIRead;

     property  ExtraObjects: TExtraObjects read FExtraObjects write FExtraObjects;
     property  IsEncrypted: boolean read FIsEncrypted;
     end;

implementation

const EncryptReKeyBlockSz = $0400;

{ TExtraObjects }

procedure TExtraObjects.Add(Name: PWideChar; LockBytes: ILockBytes; Storage: IStorage);
var
  P: PExtraData;
begin
  New(P);
  GetMem(P.Name,Length(Name) * 2 + 2);
  FillChar(P.Name^, Length(Name) * 2 + 2, 0);
  System.Move(Name^,P.Name^,Length(Name) * 2 + 2);
  P.LockBytes := LockBytes;
  P.Storage := Storage;
  inherited Add(P);
end;

procedure TExtraObjects.AddStream(Name: PWideChar; Size: integer);
var
  L: integer;
  P: PExtraStreamData;
begin
  L := Length(Name) * 2 + 2;
  New(P);
  GetMem(P.Name,L);
  System.Move(Name^,P.Name^,L);
  P.Name[Length(Name)] := #0;
  P.Size := Size;
  P.Data := Nil;
  FStreams.Add(P);
end;

procedure TExtraObjects.Clear;
var
  i: integer;
begin
  for i := 0 to FStreams.Count - 1 do begin
    FreeMem(PExtraStreamData(FStreams[i]).Name);
    FreeMem(PExtraStreamData(FStreams[i]).Data);
  end;
  FStreams.Clear;

  for i := 0 to Count - 1 do begin
    FreeMem(PExtraData(inherited Items[i]).Name);
    PExtraData(inherited Items[i]).LockBytes := Nil;
    PExtraData(inherited Items[i]).Storage := Nil;
    FreeMem(inherited Items[i]);
  end;
  inherited Clear;
end;

constructor TExtraObjects.Create;
begin
  inherited Create;
  FStreams := TList.Create;
end;

destructor TExtraObjects.Destroy;
begin
  // Clear is called by destroy;
  inherited;
  FStreams.Free;
  FStreams := Nil;
end;

function TExtraObjects.GetItems(Index: integer): PExtraData;
begin
  Result := inherited Items[Index];
end;

procedure TExtraObjects.ReadStreams(Storage: IStorage);
var
  i,p: integer;
  OleStream: IStream;
begin
  for i := 0 to FStreams.Count - 1 do begin
    GetMem(PExtraStreamData(FStreams[i]).Data,PExtraStreamData(FStreams[i]).Size);
    OleCheck(Storage.OpenStream(PExtraStreamData(FStreams[i]).Name,Nil,STGM_DIRECT or FileMode or STGM_SHARE_EXCLUSIVE,0,OleStream));
    OleCheck(OleStream.Read(PExtraStreamData(FStreams[i]).Data,PExtraStreamData(FStreams[i]).Size,@p));
  end;
end;

procedure TExtraObjects.WriteStreams(Storage: IStorage);
var
  i,p: integer;
  OleStream: IStream;
begin
  for i := 0 to FStreams.Count - 1 do begin
    OleCheck(Storage.CreateStream(PExtraStreamData(FStreams[i]).Name,STGM_DIRECT or STGM_WRITE or STGM_CREATE or STGM_SHARE_EXCLUSIVE,0,0,OleStream));
    OleCheck(OleStream.Write(PExtraStreamData(FStreams[i]).Data,PExtraStreamData(FStreams[i]).Size,@p));
  end;
end;

{ TXLSStream }

{ TXLSStream }

constructor TXLSStream.Create;
begin
  FWriteCONTINUEPos := -1;
  FSaveVBA := False;
end;

destructor TXLSStream.Destroy;
begin
  Close;
  inherited Destroy;
end;

procedure TXLSStream.Close;
begin
  if FStream <> Nil then
    FStream.Free;
  FStream := Nil;
  if OleStream <> Nil then begin
    try
      if (FTargetStream <> Nil) and (FLockBytes <> nil) then begin
        OleCheck(FLockBytes.Flush);
        OleCheck(OleStorage.Commit(STGC_DEFAULT));
        WriteStorageToDestStream;
      end;
    finally
      OleStorage := nil;
      OleStream := nil;
    end;
  end;
end;

procedure TXLSStream.ReadVBA(Name: PWideChar);
var
  StorageIn,StorageOut: IStorage;
  LockBytes: ILockBytes;
  Enum: IEnumStatStg;
  Stat: TSTATSTG;
begin
  OleCheck(OleStorage.OpenStorage(Name,Nil,STGM_READ + STGM_SHARE_EXCLUSIVE,Nil,0,StorageIn));
  OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
  OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, StorageOut));
  OleCheck(StorageIn.CopyTo(0,Nil,Nil,StorageOut));

  FExtraObjects.Add(Name,LockBytes,StorageOut);

  OleCheck(StorageOut.EnumElements(0,Nil,0,Enum));
  OleCheck(Enum.Reset);
  repeat
    OleCheck(Enum.Next(1,Stat,Nil));
  until (Stat.pwcsName = Nil);
  StorageIn := Nil;
end;

procedure TXLSStream.WriteVBA;
var
  i: integer;
  StorageOut: IStorage;
begin
  for i := 0 to FExtraObjects.Count - 1 do begin
    OleCheck(OleStorage.CreateStorage(FExtraObjects[i].Name,STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE,0,0,StorageOut));
    OleCheck(FExtraObjects[i].Storage.CopyTo(0,Nil,Nil,StorageOut));
  end;
  StorageOut := Nil;
end;

function TXLSStream.OpenOleStreamRead(Filename: PWideChar): TExcelVersion;
var
  Enum: IEnumStatStg;
  Stat: TSTATSTG;
  FoundBOOK,FoundWORKBOOK: boolean;
  FBOOKStreamSize,FWORKBOOKStreamSize: integer;
  FileMode: integer;
  DataHandle: HGLOBAL;
  Buffer: PByteArray;
begin
  Close;
  FoundBOOK := False;
  FoundWORKBOOK := False;
//  FileMode := STGM_READ;
  if FISAPIRead then
    FileMode := STGM_READ or STGM_SHARE_DENY_WRITE
  else
    FileMode := STGM_READ or STGM_TRANSACTED or STGM_SHARE_DENY_NONE;
  FWORKBOOKStreamSize := 0;
  FBOOKStreamSize := 0;

  if FSourceStream <> Nil then begin
    DataHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_NODISCARD,FSourceStream.Size);
    Buffer := GlobalLock(DataHandle);
    try
      FSourceStream.ReadBuffer(Buffer^, GlobalSize(DataHandle));
      FSourceStream.Seek(0,soFromBeginning);

      OleCheck(CreateILockBytesOnHGlobal(DataHandle, True, FLockBytes));
      OleCheck(StgOpenStorageOnILockBytes(FLockBytes, Nil, STGM_READ or STGM_TRANSACTED or STGM_SHARE_DENY_NONE , Nil, 0, OleStorage));
    finally
      GlobalUnlock(DataHandle);
    end;
  end
  else
    OleCheck(StgOpenStorage(Filename,Nil,FileMode ,Nil,0,OleStorage));

  OleCheck(OleStorage.EnumElements(0,Nil,0,Enum));
  OleCheck(Enum.Reset);
  repeat
    OleCheck(Enum.Next(1,Stat,Nil));
    if Lowercase(Stat.pwcsName) = 'book' then begin
      FoundBOOK := True;
      FBOOKStreamSize := Stat.cbSize;
    end
    else if Lowercase(Stat.pwcsName) = 'workbook' then begin
      FoundWORKBOOK := True;
      FWORKBOOKStreamSize := Stat.cbSize;
    end
    else if FSaveVBA and (Stat.dwType = 2) and not FoundBOOK and not FoundWORKBOOK then
      FExtraObjects.AddStream(Stat.pwcsName,Stat.cbSize)
    else if (Stat.dwType = 1) and FSaveVBA then
      ReadVBA(Stat.pwcsName);
  until (Stat.pwcsName = Nil);
  if not FoundBOOK and  not FoundWORKBOOK then
    raise Exception.Create(ersFileIsNotAnExcelWorkbook);
  FileMode := STGM_READ;
  if FoundWORKBOOK then begin
    Result := xvExcel97;
    FStreamSize := FWORKBOOKStreamSize;
  end
  else begin
    Result := xvExcel50;
    FStreamSize := FBOOKStreamSize;
  end;
  try
    if FExtraObjects <> Nil then
      FExtraObjects.ReadStreams(OleStorage);
    if FoundWORKBOOK then
      OleCheck(OleStorage.OpenStream('Workbook',Nil,STGM_DIRECT or FileMode or STGM_SHARE_EXCLUSIVE,0,OleStream))
    else
      OleCheck(OleStorage.OpenStream('Book',Nil,STGM_DIRECT or FileMode or STGM_SHARE_EXCLUSIVE,0,OleStream));
  except
    Result := xvNone;
  end;
end;

function TXLSStream.OpenFileStreamRead(const Filename: string): TExcelVersion;
var
  Header: TBIFFHeader;
begin
  Result := xvNone;
  Close;
  FStream := TFileStream.Create(Filename,fmOpenRead);
  FStream.Read(Header,SizeOf(TBIFFHeader));
  if (Header.RecID and $FF) = BIFFRECID_BOF then begin
    case (Header.RecID and $FF00) of
      $0000: Result := xvExcel21;
      $0200: Result := xvExcel30;
      $0400: Result := xvExcel40;
    end;
  end;
  FStream.Seek(0,soFromBeginning);
end;

function TXLSStream.Read(var Buffer; Count: Longint): integer;
var
  R,T: integer;
  P: Pointer;
  Header: TBIFFHeader;
begin
  if FStream = Nil then begin
    if FReadCONTINUEActive then begin
      if (FReadCONTINUEPos + Count) > MAXRECSZ_97 then begin
        Result := 0;
        P := @Buffer;
        repeat
          OleCheck(OleStream.Read(P,Min(MAXRECSZ_97 - FReadCONTINUEPos,Count),@R));
          Inc(Result,R);
          Dec(Count,R);
          FReadCONTINUEPos := 0;
          P := Pointer(Integer(P) + R);
          if Count > 0 then begin
            OleCheck(OleStream.Read(@Header,SizeOf(TBIFFHeader),@T));
            // Bug in Excel. MSODRAWINGGROUP may be continued with MSODRAWINGGROUP instead of CONTINUE.
            // Bug in Excel. GELFRAME may be continued with GELFRAME instead of CONTINUE.
            if not ((Header.RecID in [BIFFRECID_CONTINUE,BIFFRECID_MSODRAWINGGROUP]) or (Header.RecID = CHARTRECID_GELFRAME)) then
              raise Exception.Create('CONTINUE record is missing');
          end;
        until ((Count <= 0) or (R <= 0));
        FReadCONTINUEPos := R;
      end
      else begin
        OleCheck(OleStream.Read(@Buffer,Count,@Result));
        Inc(FReadCONTINUEPos,Count);
      end;
    end
    else begin
      OleCheck(OleStream.Read(@Buffer,Count,@Result))
    end;
  end
  else
    Result := FStream.Read(Buffer,Count);

  if FIsEncrypted and (Count > 0) then
    Decrypt(@Buffer,Count);
//    RC4(@Buffer,Count,FRC4Key);

end;

function TXLSStream.ReadUnencrypted(var Buffer; Count: Integer): longint;
var
  TempEnc: boolean;
begin
  TempEnc := FIsEncrypted;
  try
    FIsEncrypted := False;
    Result := Read(Buffer,Count);
  finally
    FIsEncrypted := TempEnc;
  end;
  if FIsEncrypted then
    EncryptSkipBytes(Pos,Count);
end;

function TXLSStream.ReadHeader(var Header: TBIFFHeader): integer;
var
  TempEnc: boolean;
begin
  TempEnc := FIsEncrypted;
  try
    FIsEncrypted := False;
    Result := Read(Header,SizeOf(TBIFFHeader));
  finally
    FIsEncrypted := TempEnc;
  end;
  if FIsEncrypted then
    EncryptSkipBytes(Pos,SizeOf(TBIFFHeader));
end;

procedure TXLSStream.WriteHeader(RecId: word; Length: word);
var
  Header: TBIFFHeader;
begin
  Header.RecId := RecId;
  Header.Length := Length;
  IntWrite(Header,SizeOf(TBIFFHeader));
end;

procedure TXLSStream.WriteBufHeader(const Buffer; RecId: word; Length: word);
var
  Header: TBIFFHeader;
begin
  Header.RecId := RecId;
  Header.Length := Length;
  IntWrite(Header,SizeOf(TBIFFHeader));
  IntWrite(Buffer,Length);
end;

procedure TXLSStream.WriteWord(RecId, Value: word);
begin
  WriteHeader(RecId,2);
  IntWrite(Value,2);
end;

function TXLSStream.IntWrite(const Buffer; Count: Integer): longint;
begin
  if FStream = Nil then
    OleCheck(OleStream.Write(@Buffer,Count,@Result))
  else
    Result := FStream.Write(Buffer,Count);
end;

function TXLSStream.Write(const Buffer; Count: Longint): longint;
begin
  Result := 0;
  if FMaxBytesWrite > 0 then
    CheckCONTINUEWrite(Buffer,Count)
  else begin
    Result := IntWrite(Buffer,Count);
    Inc(FWrittenBytes,Result);
  end;
end;

procedure TXLSStream.CheckCONTINUEWrite(const Buffer; Count: Longint);
var
  WBytes: integer;
  P: Pointer;
begin
  P := @Buffer;
  if (Count + FWrittenBytes) > FMaxBytesWrite then begin
    WBytes := FMaxBytesWrite - FWrittenBytes;
    Seek(FWriteCONTINUEPos + 2,soFromBeginning);
    IntWrite(FMaxBytesWrite,SizeOf(word));
    Seek(0,soFromEnd);
    IntWrite(P^,WBytes);
    FWriteCONTINUEPos := Pos;
    WriteHeader(BIFFRECID_CONTINUE,0);